VBAでサブフォルダ内のExcelファイルをマージする

Excelに

Excelにモジュールを追加して下記のソースを添付してください。

'パブリック変数
Public gSheet As Worksheet
Public gRow As Long
'定数
Const C_GET_ROW_S As Long = 4 '取得元データの開始行
Const C_SET_ROW_S As Long = 3 '添付先データの開始行

'サブフォルダを含むフォルダ内のファイルデータを取得する
Sub getFileData()
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        .Calculation = xlCalculationManual
    End With
    
    '初期設定
    gRow = C_SET_ROW_S
    
    Set gSheet = Sheets(1)

    '初期化
    'A～K列まで初期化
    gSheet.Range("A" & C_GET_ROW_S & ":K" & gSheet.Range("A" & Rows.Count).End(xlUp).row).ClearContents
    
    'ファイルマージ
    Dim path As String
    path = "C:\work"
    'path = gSheet.Range("B1").Value
    Call mergeData(path)
    
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        .Calculation = xlCalculationManual
    End With

End Sub

'サブフォルダも含むフォルダ内のファイルデータを探してデータをマージする
Sub mergeData(folderPath As Variant)
    
    '参照設定
    Dim fso As Object, folder As Variant, file As Variant
    Set fso = CreateObject("Scripting.FileSystemObject")
    
    'フォルダ内のサブフォルダを探す
    For Each folder In fso.GetFolder(folderPath).SubFolders
        Call mergeData(folder)
    Next
   
    Dim row As Long
    'フォルダ内のファイルを探索
    For Each file In fso.GetFolder(folderPath).Files
        'エクセル以外は対象外
        If Not (LCase(fso.GetExtensionName(file)) Like "xls*") Then
            GoTo Continue
        End If
        
        gRow = gRow + 1
        row = gRow
        
        'ファイル内のデータをコピーする
        copyData (file)
       
        With gSheet
            'ファイル情報
            .Cells(row, 1) = folderPath 'フォルダパス
            .Cells(row, 2) = file 'ファイルパス
            .Cells(row, 3) = fso.GetFileName(file) 'ファイル名
            .Cells(row, 4) = fso.GetExtensionName(file) '拡張子
            .Cells(row, 5) = fso.GetFile(file).Size 'ファイルサイズ
            .Cells(row, 6) = fso.GetFile(file).DateCreated '作成日時
            .Cells(row, 7) = fso.GetFile(file).DateLastModified '最終更新日時
            .Cells(row, 8) = fso.GetFile(file).DateLastAccessed '最終アクセス日時
            
            'データ行数分ファイル情報をコピー
            .Range("A" & row & ":H" & row).Copy
            .Range("A" & (row + 1) & ":H" & gRow).PasteSpecial xlPasteValuesAndNumberFormats
        End With
        
Continue:
    Next
    
End Sub

'データコピーを行う
Sub copyData(filePath As Variant)
    
    Dim rowEnd As Long
    
    'データの範囲はB～D列
    With Workbooks.Open(filePath)
        rowEnd = .Worksheets(1).Range("B" & Rows.Count).End(xlUp).row
        '先頭行から末尾行までコピー
        .Worksheets(1).Range("B" & C_GET_ROW_S & ":D" & rowEnd).Copy
        'このブックの1シート目へ値貼り付け
        gSheet.Cells(gRow, 9).PasteSpecial xlPasteValuesAndNumberFormats
        'コピー中状態を解除
        Application.CutCopyMode = False
        'ブックを保存せずに閉じる
        .Close False
    End With
    
    'データ行数分追加
    gRow = gRow + rowEnd - C_GET_ROW_S
    
End Sub