指定されたフォルダ配下のすべてのCSVファイルを、シートに貼り付けるマクロ

' 以下のVBAコードは、指定されたフォルダ内およびそのサブフォルダ内の
' すべてのCSVファイルを読み込み、シート1に貼り付けるものです。
' 最初のCSVファイルはそのまま貼り付け、2つ目以降のファイルは
' ヘッダーを除いて2行目から貼り付けます。
Sub ImportCSVFiles()
    Dim ws As Worksheet
    Dim folderPath As String
    Dim fileName As String
    Dim lastRow As Long
    Dim isFirstFile As Boolean
    Dim FSO As Object
    Dim folder As Object
    Dim subFolder As Object
    Dim file As Object

    ' シート1を設定
    Set ws = ThisWorkbook.Sheets("Sheet1")
    ' シート1をクリア
    ws.Cells.ClearContents
    ' フォルダパスを設定
    folderPath = ThisWorkbook.Path & "\csv\"
    ' FileSystemObjectの作成
    Set FSO = CreateObject("Scripting.FileSystemObject")
    ' フォルダオブジェクトを取得
    Set folder = FSO.GetFolder(folderPath)
    
    ' 最初のファイルフラグを設定
    isFirstFile = True

    ' フォルダ内のファイルとサブフォルダを再帰的に処理
    Call ProcessFolder(ws, folder, lastRow, isFirstFile)

    ' クリーニングアップ
    Set folder = Nothing
    Set FSO = Nothing
End Sub

'*******************************
'* フォルダ内のすべてのCSVファイルを読み込み、ワークシートに貼り付ける
'* 最初のCSVファイルはそのまま貼り付け、2つ目以降のファイルは
'* ヘッダーを除いて2行目から貼り付けます。
'* ws：ワークシート
'* folder：フォルダオブジェクト
'* lastRow：最後の行
'* isFirstFile：最初のファイルかどうか
Private Sub ProcessFolder(ByRef ws As Worksheet, _
                        ByRef folder As Object, _
                        ByRef lastRow As Long, _
                        ByRef isFirstFile As Boolean)
    Dim file As Object
    Dim subFolder As Object
    Dim data As Variant
    Dim i As Long
    
    ' フォルダ内のすべてのファイルを処理
    For Each file In folder.Files
        ' ファイルの拡張子が"csv"または"CSV"の場合のみ処理
        If LCase(Right(file.Name, 3)) = "csv" Then
            ' CSVファイルの内容を取得
            data = GetCSVData(file.Path)
            If isFirstFile Then
                ' 最初のファイルはヘッダー行も含めて貼り付け
                ws.Range("A1").Resize(UBound(data, 1), UBound(data, 2)).Value = data
                lastRow = UBound(data, 1)  ' 貼り付けた最後の行番号を更新
                isFirstFile = False  ' 最初のファイルフラグを更新
            Else
                ' 2つ目以降のファイルは2行目から貼り付け
                ws.Range("A" & lastRow + 1).Resize(UBound(data, 1) - 1, UBound(data, 2)).Value = _
                Application.Index(data, Evaluate("ROW(2:" & UBound(data, 1) & ")"), _
                Evaluate("COLUMN(1:" & UBound(data, 2) & ")"))
                lastRow = lastRow + UBound(data, 1) - 1  ' 貼り付けた最後の行番号を更新
            End If
        End If
    Next file

    ' サブフォルダ内のファイルを再帰的に処理
    For Each subFolder In folder.SubFolders
        Call ProcessFolder(ws, subFolder, lastRow, isFirstFile)
    Next subFolder
End Sub

'*******************************
'* CSVファイルを配列に入れて返す関数
'* filePath：ファイルパス名
Private Function GetCSVData(ByVal filePath As String) As Variant
    Dim tempSheet As Worksheet
    Dim data As Variant

    ' 一時的なワークシートを作成
    Set tempSheet = ThisWorkbook.Sheets.Add

    ' CSVファイルをクエリテーブルとして読み込む
    Call csv_to_sheet_QueryTables(filePath, tempSheet.Range("A1"))

    ' データを配列に格納
    data = tempSheet.UsedRange.Value

    ' 一時的なワークシートを削除
    Application.DisplayAlerts = False
    tempSheet.Delete
    Application.DisplayAlerts = True
    
    GetCSVData = data
End Function

'*******************************
'* QueryTableオブジェクトを使用して、高速にCSVをシートに取り込む。20240514
'* filePath：ファイルパス名
'* rng：取り込むシートの先頭のRange
'* charSet：文字コード。Shift_JIS, UTF-8, Unicode, JIS, UTF-7, euc-jp に対応。デフォルト：Shift_JIS
'* delimiter：区切り文字。Comma, Tab に対応。デフォルト：Comma
'* https://qiita.com/tiechel/items/40dd7cd7cf632bd6f41e
Sub csv_to_sheet_QueryTables(ByVal filePath As String, ByVal rng As Range, _
        Optional ByVal charSet As String = "Shift_JIS", _
        Optional ByVal delimiter As String = "Comma")
    
    On Error GoTo ErrorHandler
    Application.ScreenUpdating = False
    
    '文字列の書式用に配列を作成
    Dim Tcount(255) As Long
    Dim i As Long
    For i = 0 To 255                    ' 256列まで対応
        Tcount(i) = xlTextFormat        ' 文字列の書式を指定
    Next

    ' ワークシートオブジェクトを作成し、データをクリア
    Dim ws As Worksheet
    Set ws = rng.Parent
    ws.Cells.Clear

    ' QueryTablesオブジェクトを使用してcsvファイルを読み込む
    With ws.QueryTables.Add(Connection:="text;" & filePath, Destination:=rng)
        ' 文字コードの指定
        If charSet = "Shift_JIS" Then
            .TextFilePlatform = 932 'SHIFTJIS
        Else
            .TextFilePlatform = 65001 'UTF-8
        End If
        
        .AdjustColumnWidth = False '列の幅を自動計算しない
        
        ' 区切り文字を指定
        If delimiter = "Comma" Then
            .TextFileCommaDelimiter = True 'コンマ区切り
        Else
            .TextFileTabDelimiter = True
        End If
        
        ' 項目の型を指定
        .TextFileColumnDataTypes = Array(Tcount)  ' 全ての項目を文字列にする
        
        .Refresh BackgroundQuery:=False ' シートにデータを出力
        
        .Delete     ' QueryTablesオブジェクトを削除
    End With

    ws.Activate     ' ワークシートをアクティブにする

GoTo Finally:
ErrorHandler:
    MsgBox "エラーが発生しました" & vbCrLf & Err.Description & "(" & Err.Number & ")", vbExclamation
Finally:
    Application.ScreenUpdating = True
End Sub

                ' 2つ目以降のファイルは2行目から貼り付け
                ws.Range("A" & lastRow + 1).Resize(UBound(data, 1) - 1, UBound(data, 2)).Value = _
                Application.Index(data, Evaluate("ROW(2:" & UBound(data, 1) & ")"), _
                Evaluate("COLUMN(1:" & UBound(data, 2) & ")"))