さまざまなCSVを読み込み可能な

'*******
'* さまざまなCSVを読み込み可能。20230718
'* データ内に改行があっても対応可能
'* https://excel-ubara.com/excelvba5/EXCEL119.html
'* csvFile：csvファイル名、フルパス
'* csvSheetName：CSVファイルを読み込むシート名
'* FirstRange：先頭のRange
'* csvSheetNameFormat：ひな形になるシート名。これが設定されていない場合､新規作成
Sub csv_to_sheet_r1(ByVal csvFile As String, ByVal csvSheetName As String, Optional ByVal FirstRange As String = "A1", Optional csvSheetNameFormat As String = "")
    Dim varFileName As Variant
    Dim objFSO As New FileSystemObject
    Dim inTS As TextStream
    Dim strRec As String
    Dim strSplit() As String
    Dim i As Long, j As Long, k As Long
    Dim lngQuote As Long
    Dim strCell As String
    Dim blnCrLf As Boolean
  
    Dim Sheet As Worksheet
    Dim csvSheet As Worksheet
      
    '既にシート「csv」が存在する場合は削除
    For Each Sheet In ThisWorkbook.Worksheets
        If Sheet.Name = csvSheetName Then
            '確認メッセージを非表示
            Application.DisplayAlerts = False
            'シート削除
            Worksheets(csvSheetName).Delete
            '確認メッセージを表示
            Application.DisplayAlerts = True
        End If
    Next
    
    If csvSheetNameFormat = "" Then
        'シート「csv」を新規作成
        Set csvSheet = Worksheets.Add(after:=Worksheets(Worksheets.Count))
    Else
        'シート「csvSheetNameFormat」をコピー
        Worksheets(csvSheetNameFormat).Copy after:=Worksheets(Worksheets.Count)
        Set csvSheet = ActiveSheet
    End If
    ' シート名指定
    csvSheet.Name = csvSheetName
  
    varFileName = csvFile
    
    If varFileName = False Then
        Exit Sub
    End If

    Set inTS = objFSO.OpenTextFile(CStr(varFileName), ForReading)
    strRec = CStr(inTS.ReadAll)

    'i = 1 'シートの1行目から出力
    i = Range(FirstRange).Row
    
    
    
    'j = 0 '列位置はPutCellでカウントアップ
    Dim initial_j As Long
    initial_j = Range(FirstRange).Column - 1
    j = initial_j
    
    
    lngQuote = 0 'ダブルクォーテーションの数
    strCell = ""
    For k = 1 To Len(strRec)
        Select Case Mid(strRec, k, 1)
            Case vbLf, vbCr '「"」が偶数なら改行、奇数ならただの文字
                If lngQuote 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, lngQuote, csvSheet)
                        i = i + 1
                        j = initial_j
                        lngQuote = 0
                        strCell = ""
                    End If
                Else
                    strCell = strCell & Mid(strRec, k, 1)
                End If
            Case "," '「"」が偶数なら区切り、奇数ならただの文字
                If lngQuote Mod 2 = 0 Then
                    Call PutCell(i, j, strCell, lngQuote, csvSheet)
                Else
                    strCell = strCell & Mid(strRec, k, 1)
                End If
            Case """" '「"」のカウントをとる
                lngQuote = lngQuote + 1
                strCell = strCell & Mid(strRec, k, 1)
            Case Else
                strCell = strCell & Mid(strRec, k, 1)
        End Select
    Next
    '最終列の処理
    If j > 0 And strCell <> "" Then
        Call PutCell(i, j, strCell, lngQuote, csvSheet)
    End If
    
    Set inTS = Nothing
    Set objFSO = Nothing
End Sub

Sub テスト､csv_to_sheet()
    Call csv_to_sheet(ThisWorkbook.Path & "\sample9.csv", "s11")
End Sub

Sub テスト､csv_to_sheet_r1()
    Call csv_to_sheet_r1(ThisWorkbook.Path & "\sample9.csv", "s12")
End Sub