フォルダのなかのEXCEL内容を統計する

Sub 汇总数据()
    Application.ScreenUpdating = False  ' 画面更新停止
    Application.DisplayAlerts = False  ' アラート非表示
    
    Dim fd As FileDialog                ' ファイルダイアログ
    Dim folderPath As String            ' フォルダパス
    Dim fso As Object                   ' ファイルシステムオブジェクト
    Dim folder As Object                ' フォルダオブジェクト
    Dim file As Object                  ' ファイルオブジェクト
    Dim wbSource As Workbook            ' 元ワークブック
    Dim wsSource As Worksheet           ' 元ワークシート
    Dim wsDest As Worksheet             ' 出力先ワークシート
    Dim dictCols As Object              ' 列管理用辞書
    Dim destRow As Long                 ' 出力行番号
    Dim lastCol As Long                 ' 最終列番号
    Dim i As Long                       ' ループカウンタ
    
    ' 出力先シート初期設定
    Set wsDest = ThisWorkbook.ActiveSheet
    wsDest.Cells.Clear
    wsDest.Cells(1, 1) = "ファイル名"  ' ヘッダー設定
    
    ' 列位置管理辞書初期化
    Set dictCols = CreateObject("Scripting.Dictionary")
    dictCols.Add "ファイル名", 1       ' ファイル名列を登録
    lastCol = 1
    
    ' フォルダ選択ダイアログ
    Set fd = Application.FileDialog(msoFileDialogFolderPicker)
    If fd.Show = -1 Then
        folderPath = fd.SelectedItems(1)
    Else
        MsgBox "フォルダが選択されていません。処理を中止します。", vbExclamation
        Exit Sub
    End If
    
    ' ファイルコレクション取得
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set folder = fso.GetFolder(folderPath)
    
    destRow = 2  ' データ開始行
    
    ' Excelファイル処理ループ
    For Each file In folder.Files
        If LCase(Right(file.Name, 4)) Like "*.xls*" Then
            ' 読み取り専用でファイルを開く
            Set wbSource = Workbooks.Open(file.Path, True, True)
            
            ' まとめシート取得（エラー回避）
            On Error Resume Next
            Set wsSource = wbSource.Sheets("まとめ")
            On Error GoTo 0
            
            If Not wsSource Is Nothing Then
                ' データ読み込み処理
                With wsSource
                    Dim headers As Variant  ' ヘッダー行
                    Dim values As Variant   ' データ行
                    
                    headers = .Rows(1).Value  ' 1行目取得
                    values = .Rows(2).Value   ' 2行目取得
                End With
                
                ' ファイル名書き込み
                wsDest.Cells(destRow, 1) = file.Name
                
                ' 項目データ処理
                For i = 1 To UBound(headers, 2)
                    Dim colName As String  ' 項目名
                    colName = Trim(headers(1, i))
                    
                    If colName <> "" Then
                        ' 新規項目チェック
                        If Not dictCols.Exists(colName) Then
                            lastCol = wsDest.Cells(1, Columns.Count).End(xlToLeft).Column
                            lastCol = lastCol + 1
                            wsDest.Cells(1, lastCol) = colName  ' 新規ヘッダー追加
                            dictCols.Add colName, lastCol       ' 辞書に登録
                        End If
                        
                        ' 値書き込み
                        wsDest.Cells(destRow, dictCols(colName)) = values(1, i)
                    End If
                Next i
                
                destRow = destRow + 1  ' 次の行へ
            End If
            
            wbSource.Close False  ' ファイルを閉じる（保存しない）
        End If
    Next file
    
    ' 書式調整
    wsDest.Columns.AutoFit        ' 列幅自動調整
    wsDest.Rows(1).Font.Bold = True  ' ヘッダー太字
    
    Application.ScreenUpdating = True  ' 画面更新再開
    Application.DisplayAlerts = True   ' アラート表示復旧
    
    MsgBox "データの集計が完了しました！", vbInformation
End Sub