VBAで指定位置にCSV読み込み

ExcelVBA

参照の追加でMicrosoft Scripting Runtimeを追加すること 

'X=列=aStartCols Y=行=aStartRows
Sub CSV入力(aInputCsvPath, aStartCols, aStartRows)
    Dim varFileName As Variant
    Dim objFSO As New Scripting.FileSystemObject
    Dim inTS As TextStream
    Dim strRec As String
    Dim strSplit() As String
    Dim i As Long, j As Long, k As Long
    Dim lngQuate As Long
    Dim strCell As String
    Dim blnCrLf As Boolean
    
    Set inTS = objFSO.OpenTextFile(CStr(aInputCsvPath), ForReading)
    strRec = CStr(inTS.ReadAll)

    i = aStartRows 'シートの1行目から出力
    j = aStartCols '列位置はPutCellでカウントアップ
    lngQuate = 0 'ダブルクォーテーションの数
    strCell = ""
    For k = 1 To Len(strRec)
        Select Case Mid(strRec, k, 1)
            Case vbLf, vbCr '「"」が偶数なら改行、奇数ならただの文字
                If lngQuate Mod 2 = 0 Then
                    blnCrLf = False
                    If k > 1 Then '改行としてのCrLfはCrで改行判定済なので無視する
                        If Mid(strRec, k - 1, 2) = vbCrLf Then
                            blnCrLf = True
                        End If
                    End If
                    If blnCrLf = False Then
                        Call PutCell(i, j, strCell, lngQuate)
                        i = i + 1
                        j = aStartCols
                        lngQuate = 0
                        strCell = ""
                    End If
                Else
                    strCell = strCell & Mid(strRec, k, 1)
                End If
            Case "," '「"」が偶数なら区切り、奇数ならただの文字
                If lngQuate Mod 2 = 0 Then
                    Call PutCell(i, j, strCell, lngQuate)
                Else
                    strCell = strCell & Mid(strRec, k, 1)
                End If
            Case """" '「"」のカウントをとる
                lngQuate = lngQuate + 1
                strCell = strCell & Mid(strRec, k, 1)
            Case Else
                strCell = strCell & Mid(strRec, k, 1)
        End Select
    Next
    '最終列の処理
    If j > aStartCols And strCell <> "" Then
        Call PutCell(i, j, strCell, lngQuate)
    End If
    
    Set inTS = Nothing
    Set objFSO = Nothing
End Sub

Sub PutCell(ByRef i As Long, ByRef j As Long, ByRef strCell As String, ByRef lngQuate As Long)
    j = j + 1
    '「""」を「"」で置換
    strCell = Replace(strCell, """""", """")
    '前後の「"」を削除
    If Left(strCell, 1) = """" And Right(strCell, 1) = """" Then
        strCell = Mid(strCell, 2, Len(strCell) - 2)
    End If
    Cells(i, j) = strCell
    strCell = ""
    lngQuate = 0
End Sub

ネタ元