Excel VBA 逆引き集 | 実務テンプレ完全版（超再利用部品） – フォルダ内CSV連結テンプレ

Excel VBA
スポンサーリンク

ねらい：フォルダ内の複数CSVを「安全に連結」して、毎日の取り込みを一撃で自動化する

実務では「毎日たくさんのCSVを同じ列構成で連結したい」「ファイルごとのヘッダをスキップしたい」「途中で列数が違うCSVが混ざる」などの課題が頻発します。VBAで“配列I/O＋状態機械パーサ＋バッファ書き込み”の型にすれば、10万行以上でも高速・頑丈に運用できます。初心者でも貼って動くテンプレを、ヘッダ統合・列幅不一致の吸収・ソースファイル列の付与まで、例題を交えてかみ砕いて説明します。

共通基盤：CSVの安全パースと高速書き出し

CSV行の安全パース（ダブルクォート・カンマ・改行）

' ModCsv_Parse.bas
Option Explicit

' 1行のCSVを安全に分割（"..." で囲まれたカンマや改行を正しく扱う）
Public Function ParseCsvLine(ByVal line As String) As String()
    Dim res() As String: ReDim res(0 To 0)
    Dim i As Long, inQ As Boolean, cur As String
    Dim ch As String, nextCh As String
    i = 1: cur = "": inQ = False
    Do While i <= Len(line)
        ch = Mid$(line, i, 1)
        nextCh = IIf(i < Len(line), Mid$(line, i + 1, 1), "")
        If ch = """" Then
            If inQ And nextCh = """" Then
                cur = cur & """"  ' 連続 "" はエスケープ（実体は "）
                i = i + 1
            Else
                inQ = Not inQ
            End If
        ElseIf ch = "," And Not inQ Then
            Call AppendToken(res, cur): cur = ""
        Else
            cur = cur & ch
        End If
        i = i + 1
    Loop
    Call AppendToken(res, cur)
    ParseCsvLine = res
End Function

Private Sub AppendToken(ByRef arr() As String, ByVal token As String)
    Dim n As Long: n = UBound(arr) + 1
    ReDim Preserve arr(0 To n)
    ' 前後の空白はそのまま（業務要件次第で Trim へ変更可）
    arr(n) = token
End Sub
VB

重要ポイントの深掘り

  • CSVの“難所”は「ダブルクォート中のカンマ・改行」。状態機械（inQフラグ）で正しく処理します。
  • 連続“”””はエスケープされたダブルクォート。ここを誤ると列ずれや文字破壊が起きます。
  • 仕様に合わせて Trim の有無や文字正規化（全半角・大文字小文字）を入口で決めると後工程が安定します。

連結テンプレ：フォルダ内CSVをヘッダ統合＋行バッファで高速結合

フォルダ選択と一括連結（貼って動く）

' ModCsv_Concat.bas
Option Explicit

Public Sub ConcatCsvFolder(ByVal folderPath As String, ByVal outSheetName As String, _
                           Optional ByVal addSourceCol As Boolean = True, _
                           Optional ByVal skipHeaderEachFile As Boolean = True)
    If Len(Dir(folderPath, vbDirectory)) = 0 Then
        MsgBox "フォルダが存在しません: " & folderPath, vbExclamation: Exit Sub
    End If

    Dim wsOut As Worksheet: Set wsOut = PrepareOut(outSheetName)
    Dim outRow As Long: outRow = 1

    Dim files As Collection: Set files = ListCsvFiles(folderPath)
    If files.Count = 0 Then
        wsOut.Range("A1").Value = "CSVなし": Exit Sub
    End If

    Application.ScreenUpdating = False
    Application.StatusBar = "CSV連結開始..."

    ' ヘッダ統合（最初のファイルのヘッダを採用）
    Dim header() As String, maxCols As Long, f As Variant
    f = files(1)
    header = ReadFirstLine(f)
    maxCols = UBound(header) + 1

    If addSourceCol Then
        ReDim Preserve header(0 To UBound(header) + 1)
        header(UBound(header)) = "SourceFile"
        maxCols = maxCols + 1
    End If

    wsOut.Range("A1").Resize(1, maxCols).Value = header
    outRow = outRow + 1

    ' バッファ書き（チャンク）設定
    Dim buf() As Variant, bufRows As Long, CHUNK As Long
    CHUNK = 2000 ' まとめて書く行数
    ReDim buf(1 To CHUNK, 1 To maxCols)
    bufRows = 0

    ' 各ファイル処理
    Dim idx As Long
    For idx = 1 To files.Count
        Dim path As String: path = CStr(files(idx))
        Application.StatusBar = "連結中: " & idx & "/" & files.Count & " " & Dir(path)

        Dim lines As Variant: lines = ReadCsvAllLines(path)

        Dim startRow As Long: startRow = 1
        If skipHeaderEachFile Then
            ' ヘッダ判定（最初の行を飛ばす）
            startRow = 2
        End If

        Dim r As Long
        For r = startRow To UBound(lines)
            Dim cols() As String: cols = ParseCsvLine(lines(r))
            Dim c As Long, colCount As Long: colCount = UBound(cols) + 1

            bufRows = bufRows + 1
            If bufRows > CHUNK Then
                wsOut.Range("A" & outRow).Resize(CHUNK, maxCols).Value = buf
                outRow = outRow + CHUNK
                bufRows = 1
                Erase buf
                ReDim buf(1 To CHUNK, 1 To maxCols)
            End If

            ' 列を詰める（不足は空、過剰は切り捨て）
            For c = 1 To maxCols
                If c <= colCount Then
                    buf(bufRows, c) = cols(c - 1)
                ElseIf addSourceCol And c = maxCols Then
                    buf(bufRows, c) = path
                Else
                    buf(bufRows, c) = ""
                End If
            Next
            ' ソース列が必要で列数が十分なら上書き
            If addSourceCol And colCount < maxCols Then
                buf(bufRows, maxCols) = path
            End If
        Next
    Next

    ' 残りを書き出し
    If bufRows > 0 Then
        wsOut.Range("A" & outRow).Resize(bufRows, maxCols).Value = buf
        outRow = outRow + bufRows
    End If

    wsOut.Columns.AutoFit
    Application.StatusBar = False
    Application.ScreenUpdating = True
    MsgBox "CSV連結完了: " & (outRow - 2) & " 行", vbInformation
End Sub

Private Function PrepareOut(ByVal name As String) As Worksheet
    Dim ws As Worksheet
    On Error Resume Next: Set ws = Worksheets(name): On Error GoTo 0
    If ws Is Nothing Then Set ws = Worksheets.Add: ws.Name = name
    ws.Cells.Clear
    Set PrepareOut = ws
End Function

Public Function ListCsvFiles(ByVal folderPath As String) As Collection
    Dim col As New Collection, file As String
    file = Dir(folderPath & "\*.csv")
    Do While Len(file) > 0
        col.Add folderPath & "\" & file
        file = Dir()
    Loop
    Set ListCsvFiles = col
End Function

Private Function ReadFirstLine(ByVal path As String) As String()
    Dim lines As Variant: lines = ReadCsvAllLines(path)
    If UBound(lines) >= 1 Then
        ReadFirstLine = ParseCsvLine(lines(1))
    Else
        Dim empty() As String: ReDim empty(0 To 0): empty(0) = ""
        ReadFirstLine = empty
    End If
End Function

Private Function ReadCsvAllLines(ByVal path As String) As Variant
    ' UTF-8/Shift-JISなどの差異がある場合はストリームで読み込む方が安全
    Dim st As Object: Set st = CreateObject("ADODB.Stream")
    st.Type = 2 ' text
    st.Charset = "UTF-8" ' 必要に応じて "ansi"（Shift-JIS相当）へ
    st.Open: st.LoadFromFile path
    Dim txt As String: txt = st.ReadText: st.Close
    ' 改行正規化
    txt = Replace(txt, vbCrLf, vbLf)
    txt = Replace(txt, vbCr, vbLf)
    Dim arr() As String: arr = Split(txt, vbLf)
    ReadCsvAllLines = arr
End Function
VB

重要ポイントの深掘り

  • “チャンク書き”で速度を出す：配列バッファに数千行ためてから一括書き戻すと劇的に速くなります。
  • ヘッダは最初のファイルの1行目を採用。以降のファイルはヘッダ行をスキップして二重ヘッダを防ぎます。
  • 列幅不一致は「最大列数に合わせて短い方を空で埋める」。過剰列は切り捨てるか拡張するかを最初に決めます。
  • 文字コードは“UTF-8固定”にしておくと相互運用性が高い。現場がShift-JISなら Charset を “ansi” に切り替えます。

応用テンプレ：ファイル名列・ヘッダ検証・パターン絞り込み

ソースファイル列の付与とヘッダ検証

' ModCsv_Extras.bas
Option Explicit

' ヘッダ検証：最初のヘッダと一致しないCSVをリストアップ
Public Sub ValidateHeaders(ByVal folderPath As String, ByVal expectedHeader() As String, ByVal outSheet As String)
    Dim files As Collection: Set files = ListCsvFiles(folderPath)
    Dim ws As Worksheet: Set ws = PrepareOut(outSheet)
    ws.Range("A1:C1").Value = Array("File", "Match", "Message")
    Dim rowOut As Long: rowOut = 2

    Dim i As Long
    For i = 1 To files.Count
        Dim path As String: path = files(i)
        Dim hdr() As String: hdr = ReadFirstLine(path)
        Dim ok As Boolean: ok = HeaderEquals(expectedHeader, hdr)
        ws.Cells(rowOut, 1).Value = path
        ws.Cells(rowOut, 2).Value = IIf(ok, "OK", "NG")
        ws.Cells(rowOut, 3).Value = IIf(ok, "", "列数や列名が異なる可能性")
        rowOut = rowOut + 1
    Next
    ws.Columns.AutoFit
End Sub

Private Function HeaderEquals(ByRef a() As String, ByRef b() As String) As Boolean
    Dim n1 As Long: n1 = UBound(a) - LBound(a) + 1
    Dim n2 As Long: n2 = UBound(b) - LBound(b) + 1
    If n1 <> n2 Then HeaderEquals = False: Exit Function
    Dim i As Long
    For i = 0 To UBound(a)
        If a(i) <> b(i) Then HeaderEquals = False: Exit Function
    Next
    HeaderEquals = True
End Function

Private Function PrepareOut(ByVal name As String) As Worksheet
    Dim ws As Worksheet
    On Error Resume Next: Set ws = Worksheets(name): On Error GoTo 0
    If ws Is Nothing Then Set ws = Worksheets.Add: ws.Name = name
    ws.Cells.Clear
    Set PrepareOut = ws
End Function
VB

ファイルパターン絞り込み（例：日次CSVのみ）

' yyyy-mm-dd.csv 形式だけ連結する例
Public Function ListCsvFilesByPattern(ByVal folderPath As String, ByVal likePattern As String) As Collection
    Dim col As New Collection, file As String
    file = Dir(folderPath & "\*.csv")
    Do While Len(file) > 0
        If LCase$(file) Like LCase$(likePattern) Then col.Add folderPath & "\" & file
        file = Dir()
    Loop
    Set ListCsvFilesByPattern = col
End Function
VB

重要ポイントの深掘り

  • ヘッダが揃っている前提の現場でも、検証関数を1本用意しておくと“壊れたCSVの混入”にすぐ気づけます。
  • パターン絞り込みで「当日分だけ」「特定のプレフィックスだけ」を連結でき、運用の事故が減ります。

例題：フォルダ選択→CSV連結→ソース列付きで出力

実行例と使い方

' ModCsv_Example.bas
Option Explicit

Public Sub Demo_ConcatCsv()
    Dim folder As String: folder = SelectFolder()
    If Len(folder) = 0 Then Exit Sub

    ' 連結（ソース列あり、各ファイルのヘッダはスキップ）
    ConcatCsvFolder folder, "CSV_Concat", True, True
    MsgBox "フォルダ内CSVの連結が完了しました。", vbInformation
End Sub

Public Function SelectFolder() As String
    Dim dlg As FileDialog: Set dlg = Application.FileDialog(msoFileDialogFolderPicker)
    With dlg
        .Title = "CSVフォルダを選択してください"
        If .Show = -1 Then SelectFolder = .SelectedItems(1) Else SelectFolder = ""
    End With
End Function
VB

重要ポイントの深掘り

  • 使い方は「フォルダを選ぶ→OK→1枚に結合」でシンプル。失敗しない導線が現場を強くします。
  • 出力シート名は固定にしておくと下流の参照やピボットが安定します（例：CSV_Concat）。

落とし穴と対策：列ズレ・文字コード・巨大ファイル

列ズレ（ファイルごとに列数が違う）

  • 最大列数に合わせ、足りない列は空で埋める方針に統一。列名が揃っていない場合は ValidateHeaders で事前チェック。

文字コード（UTF-8とShift-JIS混在）

  • ADODB.Stream の Charset を統一。現場がShift-JIS主体なら “ansi” を採用し、UTF-8のBOM有無も併せて検討。

巨大ファイルでのメモリ

  • チャンク書き（2000行など）で分割出力。ReDim Preserve の多用は避け、固定バッファの再利用で速度を出します。

ダブルクォートや改行を含むセル

  • ParseCsvLine の状態機械で対応済み。Excel関数のSplitでは壊れるため、必ず専用パーサを使う。

まとめ：CSV連結は「安全パース＋チャンク書き＋ヘッダ統合」で速く・壊れない

  • ダブルクォート対応のパーサで“列ズレ・文字破壊”を根絶。
  • チャンク書きで10万行以上でも一瞬、UIも固まらない。
  • ヘッダは最初のファイルを採用、ソース列を付ければ追跡も簡単。
  • 列不一致・文字コード・巨大CSVの落とし穴を、テンプレ内の方針で吸収。

スポンサーリンク
タイトルとURLをコピーしました