共通のヘッダーを持つ複数CSVファイルをひとつのCSVファイルにまとめるVBA

概要

共通のヘッダーを持つ複数のCSVファイルをひとつのCSVファイルに結合する、Excel VBAのコード。
対象のCSVファイルはUTF-8。
ヘッダーの前に空白行がある場合は次の行をヘッダーとする。
ヘッダー以降の読み取りデータに空白行がある場合はスキップする。
VBA実行後、任意の複数CSVファイルを選択。
ヘッダーが正しく共通か否かのチェックは行なっていません。
結果ファイル名を入力するダイアログが出るので、入力を行うと結合処理を行う。
以下テストファイル中でヘッダーの綴りを間違えているものの、動くので気にしないでください。。

CSVファイルその１

空の行、空欄有

CSVファイルその２

結果ファイル

実際のコード

Option Explicit

Sub MergeCSVFiles()
    Dim fileDialog As fileDialog
    Dim selectedFiles As FileDialogSelectedItems
    Dim outputFileName As String
    Dim i As Long
    Dim headerLine As String
    Dim isFirstFile As Boolean
    Dim outputContent As String
    
    ' ファイル選択ダイアログを表示
    Set fileDialog = Application.fileDialog(msoFileDialogFilePicker)
    With fileDialog
        .Title = "結合するCSVファイルを選択してください"
        .Filters.Clear
        .Filters.Add "CSV Files", "*.csv"
        .AllowMultiSelect = True
        If .Show = -1 Then
            Set selectedFiles = .SelectedItems
        Else
            MsgBox "ファイルが選択されませんでした。"
            Exit Sub
        End If
    End With
    
    ' 選択されたファイルがない場合の確認
    If selectedFiles.Count = 0 Then
        MsgBox "ファイルが選択されませんでした。"
        Exit Sub
    End If
    
    ' 出力ファイル名を入力
    outputFileName = InputBox("出力ファイル名を入力してください（拡張子なし）:", "出力ファイル名", "merged_data")
    If outputFileName = "" Then
        MsgBox "出力ファイル名が入力されませんでした。"
        Exit Sub
    End If
    
    ' 拡張子を追加
    If Right(outputFileName, 4) <> ".csv" Then
        outputFileName = outputFileName & ".csv"
    End If
    
    isFirstFile = True
    outputContent = ""
    
    ' 各ファイルを処理
    For i = 1 To selectedFiles.Count
        Dim fileContent As String
        Dim lines As Variant
        Dim j As Long
        Dim headerIndex As Long
        
        ' UTF-8でファイルを読み込み
        fileContent = ReadUTF8File(selectedFiles.Item(i))
        
        ' 改行文字を統一してから分割
        fileContent = Replace(fileContent, vbCrLf, vbLf)
        fileContent = Replace(fileContent, vbCr, vbLf)
        lines = Split(fileContent, vbLf)
        
        ' ヘッダー行のインデックスを検索（最初の非空白行）
        headerIndex = -1
        For j = 0 To UBound(lines)
            If Trim(lines(j)) <> "" And lines(j) <> "" Then
                headerIndex = j
                Exit For
            End If
        Next j
        
        ' ヘッダー行が見つからない場合はスキップ
        If headerIndex = -1 Then
            Debug.Print "ヘッダー行が見つかりません: " & selectedFiles.Item(i)
            GoTo NextFile
        End If
        
        ' 各行を処理
        For j = 0 To UBound(lines)
            ' 空白行をスキップ（空文字列、空白文字のみの行）
            If Trim(lines(j)) = "" Or lines(j) = "" Then
                GoTo NextLine
            End If
            
            If isFirstFile Then
                ' 最初のファイルは全行追加（空白行以外）
                If outputContent <> "" Then
                    outputContent = outputContent & vbCrLf
                End If
                outputContent = outputContent & lines(j)
                
                ' ヘッダーを保存（最初の非空白行）
                If j = headerIndex Then
                    headerLine = lines(j)
                End If
            Else
                ' 2番目以降のファイルはヘッダー行をスキップ
                If j > headerIndex Then
                    outputContent = outputContent & vbCrLf
                    outputContent = outputContent & lines(j)
                End If
            End If
NextLine:
        Next j
        
NextFile:
        isFirstFile = False
        
        ' 進捗表示
        Application.StatusBar = "処理中: " & i & "/" & selectedFiles.Count & " ファイル完了 (" & selectedFiles.Item(i) & ")"
        
        ' デバッグ用：処理したファイル名と行数、ヘッダー位置を表示
        Debug.Print "ファイル " & i & ": " & selectedFiles.Item(i) & " - 行数: " & UBound(lines) + 1 & " - ヘッダー位置: " & headerIndex + 1
    Next i
    
    ' UTF-8で出力ファイルを保存
    Call WriteUTF8File(outputFileName, outputContent)
    
    Application.StatusBar = ""
    MsgBox "CSVファイルの結合が完了しました。" & vbNewLine & "出力ファイル: " & outputFileName & vbNewLine & "処理ファイル数: " & selectedFiles.Count
End Sub

Private Function ReadUTF8File(fileName As String) As String
    Dim stream As Object
    Set stream = CreateObject("ADODB.Stream")
    
    On Error GoTo ErrorHandler
    
    stream.Open
    stream.Type = 2 ' adTypeText
    stream.Charset = "UTF-8"
    stream.LoadFromFile fileName
    ReadUTF8File = stream.ReadText
    stream.Close
    Exit Function
    
ErrorHandler:
    If Not stream Is Nothing Then
        stream.Close
    End If
    MsgBox "ファイル読み込みエラー: " & fileName & vbNewLine & Err.Description
    ReadUTF8File = ""
End Function

Private Sub WriteUTF8File(fileName As String, content As String)
    Dim stream As Object
    Set stream = CreateObject("ADODB.Stream")
    
    On Error GoTo ErrorHandler
    
    stream.Open
    stream.Type = 2 ' adTypeText
    stream.Charset = "UTF-8"
    stream.WriteText content
    stream.SaveToFile fileName, 2 ' adSaveCreateOverWrite
    stream.Close
    Exit Sub
    
ErrorHandler:
    If Not stream Is Nothing Then
        stream.Close
    End If
    MsgBox "ファイル書き込みエラー: " & fileName & vbNewLine & Err.Description
End Sub
'''