csv読込

Option Explicit
Const CSVFILE = "C:\Users\xxx\Desktop\改行.csv"

Sub ReadFile()
Dim intRow As Integer
On Error GoTo Err
    With CreateObject("ADODB.Stream")
        .Charset = "Shift_JIS"
        .Open
        .LoadFromFile (CSVFILE)
        intRow = 1
        Do While Not (.EOS)
            Worksheets("Sheet1").Cells(intRow, 1).Value = .ReadText(-2)
            intRow = intRow + 1
        Loop
        .Close
    End With
Exit Sub
Err:
MsgBox (Err.Description)
End Sub

'http://excel-ubara.com/excelvba5/EXCEL119.html
'※参照設定で、「Microsoft Scripting Runtime」にチェックを付けて下さい。
Sub CSV入力()
   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, l As Long
   Dim lngQuate As Long
   Dim strCell As String
   Dim blnCrLf As Boolean
   
'   varFileName = Application.GetOpenFilename(FileFilter:="CSVファイル(*.csv),*.csv", _
'                         Title:="CSVファイルの選択")
'   If varFileName = False Then
'     Exit Sub
'   End If

    varFileName = CSVFILE
 
  Set inTS = objFSO.OpenTextFile(CStr(varFileName), ForReading)
   strRec = CStr(inTS.ReadAll)
 
  i = 1 'シートの1行目から出力
   j = 0 '列位置は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 = 0
             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 > 0 And strCell <> "" Then
     Call PutCell(i, j, strCell, lngQuate)
   End If
     
     MsgBox i
     '71列目に改行がある場合
     For l = 1 To i - 1
        Cells(l, 71) = Replace(Cells(l, 71), vbCrLf, "")
     Next l
   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
     If Len(strCell) <= 2 Then
       strCell = ""
     Else
       strCell = Mid(strCell, 2, Len(strCell) - 2)
     End If
   End If
   Cells(i, j) = strCell
   strCell = ""
   lngQuate = 0
 End Sub