CSVの読み込み方法（改）｜ExcelマクロVBAサンプル集

最終更新日：2018-12-26

CSVの読み込み方法（改）

実施したいこと
・ファイル名を指定し、形式をカンマ区切り、文字列で開く、
　その際、改行コードLF、CRLF、CRいずれにも対応、
　セル内の","や改行についてはカラムで区切らない。

掲示板で上記のリクエストを頂きました。

ということで、対応ロジックを書いてみました。

「CSVの読込方法」この中のVBAコードを改良したものです。

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
　　Dim lngQuote 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

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

　　i = 1 'シートの1行目から出力
　　j = 0 '列位置はPutCellでカウントアップ
　　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)
　　　　　　　　　　　　i = i + 1
　　　　　　　　　　　　j = 0
　　　　　　　　　　　　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)
　　　　　　　　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)
　　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 lngQuote 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 = ""
　　lngQuote = 0
End Sub

※参照設定で、「Microsoft Scripting Runtime」にチェックを付けて下さい。

CrとLfの判定部分が、ちょっとまどろっこしい感じになっちゃいました。

Crだけってデータが実際にあるのか不明なのですが、これなら、大抵は大丈夫だろうと思いますし、

いろいろなパターンが出てきても、ロジックで対応可能になります。

ただですね、Cr、Lfのの組み合わせがめちゃくちゃだったりすると、どうなるか・・・

そのようなテストデータを用意するのが大変なので・・・

こういう場合に、正しく読めなかった等があれば、報告もらえれば対応しますね。