VBA CSV読み込み(ADODB Stream)

CSV読み込み(ADODB.Stream)

  • ADODB Streamを利用してCSVを読み込む
  • Shift JIS、UTF-8(BOM有)に対応
  • UTF-8(BOMなし)は、FileSystemObject利用がお勧め

Option Explicit

Sub ImportCsvSimple()
    '★CSVデータにタイトル行がある場合の出力制御
    Const INCLUDE_HEADER As Boolean = True  '含む：True／含まない：False
    
    '★文字コードの指定（※UTF-8はBOMありのみ対応）
    Const CHAR_SET As String = "utf-8"      'Shift-JIS:「shift-jis」／UTF-8(BOMあり):「utf-8」
    
    Dim stream As Object
    Dim filePath As String
    Dim dataLines As Variant
    Dim fields As Variant
    Dim records As Collection: Set records = New Collection
    Dim ws As Worksheet
    Dim i As Long, r As Long, c As Long
    Dim line As String
    Dim rowCount As Long, colCount As Long
    Dim result() As Variant
    
    On Error GoTo ErrHandler
    
    '出力先シート
    Set ws = ThisWorkbook.Worksheets("import")
    
    'CSVファイル選択
    filePath = Application.GetOpenFilename("CSVファイル(*.csv),*.csv")
    If filePath = "False" Then Exit Sub
    
    'ADODB.Streamによる読み込み
    Set stream = CreateObject("ADODB.Stream")
    With stream
        .CharSet = CHAR_SET
        .Open
        .Type = 2 '※テキスト読み込みはOpen直後に設定
        .LoadFromFile filePath
        .Position = 0
        .LineSeparator = -1
        dataLines = Split(.ReadText, vbLf) '※CR/LF混在でも対応
        .Close
    End With
    
    'レコード解析
    For i = LBound(dataLines) To UBound(dataLines)
        line = Trim$(dataLines(i))
        If line <> "" Then
            If i = 0 Then
                If INCLUDE_HEADER Then
                    fields = ParseCsvLine(line)
                    records.Add fields
                End If
            Else
                fields = ParseCsvLine(line)
                records.Add fields
            End If
        End If
    Next i
    
    If records.Count = 0 Then
        MsgBox "データがありません", vbExclamation
        Exit Sub
    End If
    
    '2次元配列変換
    rowCount = records.Count
    colCount = UBound(records(1)) + 1
    ReDim result(1 To rowCount, 1 To colCount)
    
    For r = 1 To rowCount
        fields = records(r)
        For c = 1 To colCount
            If c - 1 <= UBound(fields) Then
                result(r, c) = fields(c - 1)
            Else
                result(r, c) = ""
            End If
        Next c
    Next r
    
    'Excelへ出力（デバッグ用途）
    ws.Cells.Clear
    ws.Range("A1").Resize(rowCount, colCount).Value = result
    
    MsgBox "読込完了!", vbInformation
    
CleanUp:
    On Error Resume Next
    If Not stream Is Nothing Then
        If stream.State = 1 Then stream.Close
    End If
    Set stream = Nothing
    Exit Sub
    
ErrHandler:
    MsgBox "エラー：" & Err.Description, vbCritical
    Resume CleanUp
End Sub

'==============================
' CSV 1行をRFC簡易準拠で解析
'==============================
Private Function ParseCsvLine(ByVal csvLine As String) As Variant
    Dim result As Collection: Set result = New Collection
    Dim i As Long, ch As String
    Dim buf As String: buf = ""
    Dim inQuote As Boolean: inQuote = False
    
    For i = 1 To Len(csvLine)
        ch = Mid$(csvLine, i, 1)
        
        Select Case ch
            Case """" ' ダブルクォート
                If inQuote And i < Len(csvLine) And Mid$(csvLine, i + 1, 1) = """" Then
                    buf = buf & """" ' 連続 → エスケープとして追加
                    i = i + 1
                Else
                    inQuote = Not inQuote ' 引用状態トグル
                End If
                
            Case "," ' カンマ
                If inQuote Then
                    buf = buf & ch
                Else
                    result.Add buf: buf = ""
                End If
                
            Case Else
                buf = buf & ch
        End Select
    Next i
    
    result.Add buf ' 最後
    
    ' Collection → Variant配列化
    Dim arr() As String
    ReDim arr(0 To result.Count - 1)
    For i = 1 To result.Count
        arr(i - 1) = result(i)
    Next
    
    ParseCsvLine = arr
End Function

コメント