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

最終更新日：2018-12-26

CSVの読み込み方法（改）

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

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

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

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

エクセルのVBAでのCSVの読込方法としては。・テキストファイルとして読み込む・ワークブックとして読み込む・クエリーテーブルを使う・ADOを使う・PowerQueryを使う大別するとこのようになります。この記事を書いた当初はエクセルのVBAでCSVの読み込みについてネットで検索したところ




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