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