VBAのCSV読み込み ダブルクォーテーション内のカンマと改行

'==============================================================================
' modCsv : CSV 読み込みモジュール (Excel / Access 共通・参照設定不要)
'
' 対応していること
'   ・囲み文字内の区切り文字           "東京,大阪"         → 東京,大阪
'   ・エスケープされた囲み文字         "say ""hi"""        → say "hi"
'   ・囲み文字内の改行 (複数行にまたがるフィールド。改行コードも元のまま保持)
'   ・改行コード CRLF / LF / CR を自動判定 (CRLF と LF の混在も可)
'   ・文字コード自動判定 (BOM 付き UTF-8 / UTF-16、BOM 無し UTF-8、それ以外は Shift_JIS)
'   ・区切り文字・囲み文字の変更 (TSV など。囲み文字 "" で囲み処理なし)
'
' 崩れたデータもエラーにせず、次のように読む (Excel / Python の csv とほぼ同じ挙動)
'   ・囲まれていないフィールド途中の "      5"3          → 5"3
'   ・閉じ囲みの直後に続く文字             "abc"def     → abcdef
'   ・ファイル末尾まで閉じられない囲み     → そこまでを 1 フィールドとして確定
'
' 比較はすべてバイナリ比較で書いているので、Access の Option Compare Database
' のモジュールに貼り付けても動作は変わらない
'
' 使用例
'   Dim rows As Variant, r As Long
'   rows = CsvReadFile("C:\data\sample.csv")
'   For r = 0 To UBound(rows)          ' 0 件なら UBound = -1 なのでループしない
'       Debug.Print rows(r)(0), rows(r)(1)
'   Next
'==============================================================================
Option Explicit

Private Const adTypeBinary As Long = 1
Private Const adTypeText As Long = 2
Private Const adReadLine As Long = -2
Private Const adCR As Long = 13
Private Const adLF As Long = 10

Private Const SAMPLE_BYTES As Long = 1048576     ' 文字コード・改行コード判定に使う先頭バイト数

'------------------------------------------------------------------------------
' CSV ファイルを 1 行ずつ読み込み、レコードの配列を返す
'
'   filePath       : CSV ファイルのパス
'   charset        : "auto"(既定) / "Shift_JIS" / "UTF-8" / "Unicode"(UTF-16LE) など
'                    ※ADODB.Stream の Charset に渡せる名前ならなんでも可
'   delimiter      : 区切り文字 (既定 ",")。TSV なら vbTab
'   quoteChar      : 囲み文字 (既定 """")。"" を渡すと囲みを解釈しない
'   skipEmptyLines : True(既定) なら空行を読み飛ばす。False なら空文字 1 個のレコードになる
'
'   戻り値 : 0 始まりの Variant 配列。各要素はそのレコードの String 配列 (0 始まり)
'            → rows(行)(列) で参照する。0 件のときは UBound = -1 の空配列
'            行ごとに列数が違ってもそのまま返す (揃えたいときは CsvTo2DArray)
'------------------------------------------------------------------------------
Public Function CsvReadFile(ByVal filePath As String, _
                            Optional ByVal charset As String = "auto", _
                            Optional ByVal delimiter As String = ",", _
                            Optional ByVal quoteChar As String = """", _
                            Optional ByVal skipEmptyLines As Boolean = True) As Variant
    Dim stm As Object
    Dim sample() As Byte
    Dim lineSep As Long
    Dim rows() As Variant, rowCount As Long
    Dim fields() As String, fieldCount As Long
    Dim fieldBuf As String, inQuotes As Boolean
    Dim lineText As String, lineNo As Long, recordStartLine As Long
    Dim hadCR As Boolean, pendingNewline As String
    Dim doParse As Boolean

    ValidateChars delimiter, quoteChar

    Set stm = CreateObject("ADODB.Stream")
    stm.Type = adTypeBinary
    stm.Open
    stm.LoadFromFile filePath

    If stm.Size = 0 Then
        stm.Close
        CsvReadFile = Array()
        Exit Function
    End If

    ' 先頭部分のバイト列から文字コードと改行コードを判定する
    If stm.Size < SAMPLE_BYTES Then sample = stm.Read(stm.Size) Else sample = stm.Read(SAMPLE_BYTES)
    If LCase$(charset) = "auto" Then charset = DetectCharset(sample)
    lineSep = DetectLineSeparator(sample)

    ' テキストモードに切り替えて先頭から 1 行ずつ読む
    stm.Position = 0
    stm.Type = adTypeText
    stm.Charset = charset
    stm.LineSeparator = lineSep     ' CRLF のファイルも LF で区切り、行末の CR は下で外す

    ReDim rows(0 To 255)
    ReDim fields(0 To 15)

    Do Until stm.EOS
        lineText = stm.ReadText(adReadLine)
        lineNo = lineNo + 1

        ' BOM (U+FEFF) が残っていたら除去
        If lineNo = 1 Then
            If CharCodeAt(lineText, 1) = &HFEFF& Then lineText = Mid$(lineText, 2)
        End If

        ' 行末の CR を外す (囲みの中の改行だった場合は pendingNewline で元に戻す)
        hadCR = (CharCodeAt(lineText, Len(lineText)) = 13)
        If hadCR Then lineText = Left$(lineText, Len(lineText) - 1)

        If inQuotes Then
            fieldBuf = fieldBuf & pendingNewline        ' 囲みの中の改行はデータとして残す
            doParse = True
        Else
            recordStartLine = lineNo
            doParse = Not (skipEmptyLines And Len(lineText) = 0)
        End If

        If doParse Then
            If ParseLine(lineText, delimiter, quoteChar, inQuotes, fieldBuf, fields, fieldCount) Then
                AddRecord rows, rowCount, fields, fieldCount
            ElseIf lineSep = adCR Then
                pendingNewline = vbCr                   ' 囲みの中で行が終わった → 次の行へ続く
            ElseIf hadCR Then
                pendingNewline = vbCrLf
            Else
                pendingNewline = vbLf
            End If
        End If
    Loop
    stm.Close

    ' 囲みが閉じないままファイルが終わった → 読めたところまでで確定する
    If inQuotes Then
        Debug.Print "CsvReadFile: " & recordStartLine & " 行目から始まる囲み文字が閉じられていません : " & filePath
        AddField fields, fieldCount, fieldBuf
        AddRecord rows, rowCount, fields, fieldCount
    End If

    If rowCount = 0 Then
        CsvReadFile = Array()
    Else
        ReDim Preserve rows(0 To rowCount - 1)
        CsvReadFile = rows
    End If
End Function

'------------------------------------------------------------------------------
' 1 レコード分の文字列を分割して String 配列 (0 始まり) で返す
'   Line Input などで自前で読んだ行を分割したいとき用
'   (囲みの中に改行が入っている文字列を渡してもよい)
'------------------------------------------------------------------------------
Public Function CsvParseLine(ByVal lineText As String, _
                             Optional ByVal delimiter As String = ",", _
                             Optional ByVal quoteChar As String = """") As String()
    Dim fields() As String, fieldCount As Long
    Dim fieldBuf As String, inQuotes As Boolean

    ValidateChars delimiter, quoteChar
    ReDim fields(0 To 15)

    If Not ParseLine(lineText, delimiter, quoteChar, inQuotes, fieldBuf, fields, fieldCount) Then
        AddField fields, fieldCount, fieldBuf           ' 囲みが閉じていない → 残りを最後のフィールドにする
    End If

    ReDim Preserve fields(0 To fieldCount - 1)
    CsvParseLine = fields
End Function

'------------------------------------------------------------------------------
' CsvReadFile の戻り値を 2 次元配列 (行, 列) に変換する (どちらも 0 始まり)
'   列数が足りない行は Empty で埋める。Excel の Range.Value にそのまま代入できる
'   0 件のときは Empty を返す
'------------------------------------------------------------------------------
Public Function CsvTo2DArray(ByRef rows As Variant) As Variant
    Dim result() As Variant
    Dim r As Long, c As Long, colCount As Long

    If UBound(rows) < 0 Then Exit Function

    For r = 0 To UBound(rows)
        If UBound(rows(r)) + 1 > colCount Then colCount = UBound(rows(r)) + 1
    Next

    ReDim result(0 To UBound(rows), 0 To colCount - 1)
    For r = 0 To UBound(rows)
        For c = 0 To UBound(rows(r))
            result(r, c) = rows(r)(c)
        Next
    Next
    CsvTo2DArray = result
End Function

'------------------------------------------------------------------------------
' 1 行分を解析してフィールドを fields に追加していく (内部処理)
'   inQuotes / fieldBuf / fields / fieldCount は行をまたいで状態を引き継ぐ
'   戻り値 : True  = レコードが完結した
'            False = 囲みの中で行が終わった (次の行に続く)
'------------------------------------------------------------------------------
Private Function ParseLine(ByRef lineText As String, ByVal delimiter As String, ByVal quoteChar As String, _
                           ByRef inQuotes As Boolean, ByRef fieldBuf As String, _
                           ByRef fields() As String, ByRef fieldCount As Long) As Boolean
    Dim pos As Long, hit As Long, lineLen As Long
    Dim quoteCode As Long
    Dim atFieldStart As Boolean

    If Len(quoteChar) = 0 Then quoteCode = -1 Else quoteCode = AscW(quoteChar) And &HFFFF&
    lineLen = Len(lineText)
    pos = 1
    atFieldStart = Not inQuotes

    Do While pos <= lineLen
        If inQuotes Then
            ' 囲みの中 : 次の囲み文字までをそのまま取り込む
            hit = InStr(pos, lineText, quoteChar, vbBinaryCompare)
            If hit = 0 Then
                fieldBuf = fieldBuf & Mid$(lineText, pos)
                Exit Function                               ' 囲みの中で行末 → 次の行へ続く
            End If
            fieldBuf = fieldBuf & Mid$(lineText, pos, hit - pos)

            If CharCodeAt(lineText, hit + 1) = quoteCode Then
                fieldBuf = fieldBuf & quoteChar             ' "" → " (エスケープ)
                pos = hit + 2
            Else
                inQuotes = False                            ' 閉じ囲み
                pos = hit + 1
            End If

        ElseIf atFieldStart And CharCodeAt(lineText, pos) = quoteCode Then
            ' フィールド先頭の囲み文字 → 囲み開始
            inQuotes = True
            atFieldStart = False
            pos = pos + 1

        Else
            ' 囲みの外 : 次の区切り文字までを取り込む
            ' (途中にある " や、閉じ囲みの後ろに続く文字はそのまま値として扱う)
            hit = InStr(pos, lineText, delimiter, vbBinaryCompare)
            If hit = 0 Then
                fieldBuf = fieldBuf & Mid$(lineText, pos)
                pos = lineLen + 1
            Else
                fieldBuf = fieldBuf & Mid$(lineText, pos, hit - pos)
                AddField fields, fieldCount, fieldBuf
                atFieldStart = True
                pos = hit + 1
            End If
        End If
    Loop

    If inQuotes Then Exit Function      ' 行末が """ や空行など、囲みの中で終わった → 次の行へ続く

    AddField fields, fieldCount, fieldBuf       ' 行末 = 最後のフィールドの終わり
    ParseLine = True
End Function

' fieldBuf を 1 フィールドとして確定する
Private Sub AddField(ByRef fields() As String, ByRef fieldCount As Long, ByRef fieldBuf As String)
    If fieldCount > UBound(fields) Then ReDim Preserve fields(0 To fieldCount * 2 + 1)
    fields(fieldCount) = fieldBuf
    fieldCount = fieldCount + 1
    fieldBuf = vbNullString
End Sub

' fields を 1 レコードとして確定する
Private Sub AddRecord(ByRef rows() As Variant, ByRef rowCount As Long, _
                      ByRef fields() As String, ByRef fieldCount As Long)
    ReDim Preserve fields(0 To fieldCount - 1)
    If rowCount > UBound(rows) Then ReDim Preserve rows(0 To rowCount * 2 - 1)
    rows(rowCount) = fields                     ' 配列のコピーが格納される
    rowCount = rowCount + 1
    fieldCount = 0
End Sub

' 指定位置の文字コード (0～65535)。範囲外なら -1
Private Function CharCodeAt(ByRef s As String, ByVal pos As Long) As Long
    If pos >= 1 And pos <= Len(s) Then
        CharCodeAt = AscW(Mid$(s, pos, 1)) And &HFFFF&
    Else
        CharCodeAt = -1
    End If
End Function

Private Sub ValidateChars(ByVal delimiter As String, ByVal quoteChar As String)
    If Len(delimiter) <> 1 Or Len(quoteChar) > 1 Then
        Err.Raise 5, "modCsv", "区切り文字は 1 文字、囲み文字は 1 文字か空文字で指定してください。"
    End If
    If StrComp(delimiter, quoteChar, vbBinaryCompare) = 0 Then
        Err.Raise 5, "modCsv", "区切り文字と囲み文字に同じ文字は指定できません。"
    End If
End Sub

'------------------------------------------------------------------------------
' 文字コードの推定
'   BOM があればそれに従う。無ければ UTF-8 として正しいバイト列かを検査し、
'   正しければ UTF-8、そうでなければ Shift_JIS とみなす
'   (ASCII だけのファイルは Shift_JIS 扱い。どちらで読んでも結果は同じ)
'------------------------------------------------------------------------------
Private Function DetectCharset(ByRef b() As Byte) As String
    Dim i As Long, k As Long, last As Long, need As Long
    Dim hasMultiByte As Boolean

    last = UBound(b)
    If last >= 2 Then
        If b(0) = &HEF And b(1) = &HBB And b(2) = &HBF Then DetectCharset = "UTF-8": Exit Function
    End If
    If last >= 1 Then
        If b(0) = &HFF And b(1) = &HFE Then DetectCharset = "Unicode": Exit Function
        If b(0) = &HFE And b(1) = &HFF Then DetectCharset = "unicodeFFFE": Exit Function
    End If

    i = 0
    Do While i <= last
        Select Case b(i)
            Case Is < &H80:     need = 0
            Case &HC2 To &HDF:  need = 1
            Case &HE0 To &HEF:  need = 2
            Case &HF0 To &HF4:  need = 3
            Case Else:          DetectCharset = "Shift_JIS": Exit Function
        End Select

        For k = 1 To need
            If i + k > last Then Exit Do            ' サンプルの末尾で文字が途切れた
            If b(i + k) < &H80 Or b(i + k) > &HBF Then DetectCharset = "Shift_JIS": Exit Function
        Next
        If need > 0 Then hasMultiByte = True
        i = i + need + 1
    Loop

    If hasMultiByte Then DetectCharset = "UTF-8" Else DetectCharset = "Shift_JIS"
End Function

'------------------------------------------------------------------------------
' 改行コードの推定
'   LF があれば LF 区切り (CRLF は行末の CR を外して対応)、CR しか無ければ CR 区切り
'------------------------------------------------------------------------------
Private Function DetectLineSeparator(ByRef b() As Byte) As Long
    Dim i As Long, hasCR As Boolean

    For i = 0 To UBound(b)
        If b(i) = 10 Then DetectLineSeparator = adLF: Exit Function
        If b(i) = 13 Then hasCR = True
    Next
    If hasCR Then DetectLineSeparator = adCR Else DetectLineSeparator = adLF
End Function