VBA CSV読み込み(ADODB.Stream)必要項目のみ

CSV読み込み(ADODB.Stream)必要項目のみ

  • ADODB Streamを利用してCSVを読み込む
  • Shift JIS、UTF-8(BOM有)に対応
  • UTF-8(BOMなし)は、FileSystemObject利用がお勧め
  • 必要な項目データのみを取り込む(必要項目はシートから呼び込む)

各プロシージャ構成

  • Sub ImportCsv_Mapping()
    • Private Function ParseCsvLine(ByVal csvLine As String) As Variant
      　CSV 1行をRFC簡易準拠で解析して各要素に分割
    • Private Sub LoadMappingSettings(ByRef mapDict As Object, ByRef typeDict As Object, ByRef colKeys As Object)
      　「Mapping」シートのデータを格納
    • Private Sub ValidateHeaders(header As Variant, mapDict As Object)
      　マッピングされた要素番号に対する要素名に誤りがないかチェック
    • Private Sub QuickSort(arr As Variant, left As Long, right As Long)
      　マッピングのキーの並び替え

利用データ

sample_sjis_crlf.ダウンロード
sample_utf8_bom_lfダウンロード
csv取り込み準備ダウンロード

ソースコード

'======================================================
' CSV読込（Mapping仕様に従って動作）
'======================================================

Sub ImportCsv_Mapping()
    Const CHAR_SET As String = "utf-8"
    Const INCLUDE_HEADER As Boolean = True

    Dim stream As Object
    Dim filePath As String
    Dim dataLines As Variant
    Dim header As Variant
    Dim fields As Variant
    Dim ws As Worksheet
    Dim mapDict As Object
    Dim typeDict As Object
    Dim colKeys As Object
    Dim result() As Variant
    Dim keys As Variant

    Dim lastCol As Long
    Dim rowCount As Long
    Dim i As Long, r As Long, c As Long
    Dim mapCol As Long
    Dim val As String
    Dim colType As String
    Dim line As String
    Dim startRow As Long

    On Error GoTo ErrHandler

    '=== Mapping設定読込 ===
    LoadMappingSettings mapDict, typeDict, colKeys

    '--- 列番号(Key)配列化 → ソート ---
    keys = colKeys.keys
    QuickSort keys, LBound(keys), UBound(keys)

    lastCol = UBound(keys) + 1


    '--- 出力先シート ---
    Set ws = ThisWorkbook.Worksheets("import")
    ws.Cells.Clear


    '--- CSV選択 ---
    filePath = Application.GetOpenFilename("CSVファイル(*.csv),*.csv")
    If filePath = "False" Then Exit Sub


    '--- CSV読込 ---
    Set stream = CreateObject("ADODB.Stream")
    With stream
        .CharSet = CHAR_SET
        .Open
        .Type = 2
        .LoadFromFile filePath
        .Position = 0
        .LineSeparator = -1
        dataLines = Split(.ReadText, vbLf)
        .Close
    End With


    '--- ヘッダ取得＆検証 ---
    header = ParseCsvLine(Trim$(dataLines(0)))
    ValidateHeaders header, mapDict


    '--- 配列準備 ---
    rowCount = UBound(dataLines)
    ReDim result(1 To rowCount, 1 To lastCol)
    r = 1
    
    '--- データ行ループ ---
    If INCLUDE_HEADER Then
        startRow = 0 'タイトル行も含める
    Else
        startRow = 1 'タイトル行は飛ばす
    End If
    
    For i = startRow To UBound(dataLines)
        line = Trim$(dataLines(i))
        If Len(line) > 0 Then
            fields = ParseCsvLine(line)

            For c = 1 To lastCol
                mapCol = CLng(keys(c - 1))

                If mapCol - 1 <= UBound(fields) Then
                    val = fields(mapCol - 1)
                Else
                    val = ""
                End If

                colType = typeDict(CStr(mapCol))

                Select Case colType
                    Case "STR"
                        result(r, c) = "'" & val

                    Case "DATE"
                        If Trim$(val) = "" Then
                            result(r, c) = ""
                        ElseIf IsDate(val) Then
                            result(r, c) = CDate(Format$(val, "yyyy/mm/dd"))
                        Else
                            result(r, c) = val
                        End If

                    Case "NUM"
                        If IsNumeric(val) Then
                            result(r, c) = CDbl(val)
                        Else
                            result(r, c) = val
                        End If

                    Case Else
                        result(r, c) = val
                End Select
            Next c
            r = r + 1
        End If
    Next i

    '--- 転記（出力件数チェック）
    If r > 1 Then
        ws.Range("A1").Resize(r - 1, lastCol).Value = result
    Else
        MsgBox "出力対象データがありません。", vbExclamation
        Exit Sub
    End If

    MsgBox "読込完了!", vbInformation


CleanUp:
    On Error Resume Next
    If Not stream Is Nothing Then If stream.State = 1 Then stream.Close
    Set stream = Nothing
    Exit Sub


ErrHandler:
    MsgBox "エラー：" & Err.Description, vbCritical
    Resume CleanUp

End Sub
'======================================================
' Mapping仕様読込
'======================================================
Sub LoadMappingSettings(ByRef mapDict As Object, ByRef typeDict As Object, ByRef colKeys As Object)
    Dim ws As Worksheet: Set ws = ThisWorkbook.Worksheets("Mapping")
    Dim i As Long, lastRow As Long
    Dim colNo As Long, colName As String, colType As String
    
    Set mapDict = CreateObject("Scripting.Dictionary")
    Set typeDict = CreateObject("Scripting.Dictionary")
    Set colKeys = CreateObject("Scripting.Dictionary")
    
    lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
    
    For i = 2 To lastRow
        colNo = ws.Cells(i, 1).Value
        colName = CStr(ws.Cells(i, 2).Value)
        colType = UCase$(Trim$(ws.Cells(i, 3).Value))
        
        mapDict(colName) = colNo
        typeDict(CStr(colNo)) = colType
        colKeys.Add CStr(colNo), CStr(colNo) '列番号順保持
    Next
End Sub


'======================================================
' ヘッダ誤り検証
'======================================================
Sub ValidateHeaders(header As Variant, mapDict As Object)
    Dim key As Variant
    For Each key In mapDict.keys
        Dim idx As Long
        idx = mapDict(key) - 1
        If idx > UBound(header) Or header(idx) <> key Then
            Err.Raise vbObjectError + 1000, , _
                "ヘッダ不一致：" & key & vbCrLf & _
                "CSV仕様を確認してください。"
        End If
    Next
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

'======================================================
' 数値として昇順に並び替え
'======================================================
Sub QuickSort(arr As Variant, left As Long, right As Long)
    Dim pivot As Long
    Dim i As Long
    Dim j As Long
    Dim tmp As Variant
    
    i = left
    j = right
    pivot = CLng(arr((left + right) \ 2)) ' 中央値をピボットに
    
    Do
        Do While CLng(arr(i)) < pivot
            i = i + 1
        Loop
        
        Do While CLng(arr(j)) > pivot
            j = j - 1
        Loop
        
        If i <= j Then
            tmp = arr(i)
            arr(i) = arr(j)
            arr(j) = tmp
            
            i = i + 1
            j = j - 1
        End If
    Loop While i <= j
    
    If left < j Then QuickSort arr, left, j
    If i < right Then QuickSort arr, i, right
End Sub

コメント