フォルダ内のExcelファイルから特定のデータを抽出し、メインのExcelファイルに転記

Sub TransferData()

    ' tblResultテーブルの列数を取得する
    Dim 列数 As Long
    列数 = wsTBL.Range("tblResult[#All]").Columns.Count

    ' 3列目以降の余分な列を削除
    Dim clm As Long
    If 列数 > 2 Then
        ' 3列目以降の列を順番に削除
        For clm = 3 To 列数
            wsTBL.ListObjects("tblResult").ListColumns(3).Delete
        Next clm
    End If

    ' 抽出対象ファイル名が空でない場合、tblResultテーブルのデータをクリア
    If wsTBL.Range("tblResult[抽出対象ファイル名]")(1) <> "" Then
        wsTBL.ListObjects("tblresult").DataBodyRange.Delete
    End If

    ' 見出しを設定
    Dim rw As Long
    With wsTBL
        ' 抽出設定の最大行数を取得
        maxRw = .Range("tblSetting[#Data]").Rows.Count
        For rw = 1 To maxRw
            .Range("tblResult[#All]")(0).Offset(0, rw + 1) = "抽出id=" & .Range("tblSetting[id]")(rw)
        Next rw
    End With
    
    ' 保管先フォルダのパスを指定
    Dim folderName As String
    folderName = ThisWorkbook.Path & "\保管先"

    ' 処理するファイルの拡張子を配列に格納
    Dim myArray As Variant
    myArray = Array("xlsx") ' xlsxファイルのみ対象とする

    ' 指定したフォルダ内のファイルに対して処理を実行
    Call ProcessFilesInFolderIncludeExtension(folderName, myArray)

End Sub


'**********************************
'* 指定したフォルダ内のファイルに対して同じ処理を行うサブプロシージャ
'* folderPath：フォルダパス名
'* myArray：対象となるファイルの拡張子が格納された配列
Private Sub ProcessFilesInFolderIncludeExtension(ByVal folderPath As String, ByRef myArray As Variant)
    Dim fso As Object
    Dim file As Object

    ' FileSystemObjectを作成して、ファイル操作を簡略化
    Set fso = CreateObject("Scripting.FileSystemObject")

    ' 指定されたフォルダ内の各ファイルに対して処理を実行
    For Each file In fso.GetFolder(folderPath).Files
        ' ファイルの拡張子を取得
        Dim extension As String
        extension = fso.GetExtensionName(file.Name)

        ' ファイルの拡張子が配列に含まれるか確認
        Dim flg As Boolean: flg = False
        Dim i As Long
        For i = LBound(myArray) To UBound(myArray)
            If myArray(i) = extension Then
                ' 拡張子が一致した場合
                flg = True
                Exit For
            End If
        Next i

        ' 拡張子が一致した場合、ファイルに対する処理を実行
        If flg Then
            Call ProcessFile(file)
        End If
    Next file

    ' オブジェクトのメモリ解放
    Set fso = Nothing
End Sub

'**********************************
'* 各ファイルに対する処理を行うサブプロシージャ
'* file：Fileオブジェクト
Private Sub ProcessFile(ByRef file As Object)

    ' ファイルを開く
    Dim wb As Workbook
    Set wb = Workbooks.Open(file.Path)

    ' 処理対象のブックをアクティブにする
    ThisWorkbook.Activate

    ' 各種変数の宣言
    Dim rw As Long        ' 抽出対象の行番号
    Dim maxRw As Long     ' 抽出設定シートの最大行
    Dim シート名 As String  ' 抽出シート名
    Dim セルアドレス As String  ' 抽出セルのアドレス
    Dim 転記データ As Variant   ' 抽出したデータの格納先

    ' tblResultの最終行を取得
    Dim lastRw As Long
    lastRw = wsTBL.Range("tblResult[#Data]").Rows.Count
    If lastRw = 1 Then
        ' 抽出対象ファイル名が空の場合は0行として扱う
        If wsTBL.Range("tblResult[抽出対象ファイル名]") = "" Then
            lastRw = 0
        End If
    End If
    lastRw = lastRw + 1

    ' tblResultに開いたファイル名を転記
    wsTBL.Range("tblResult[抽出対象ファイル名]")(lastRw) = wb.Name

    ' tblSettingシートから抽出設定を読み込み、抽出処理を行う
    With wsTBL
        ' 抽出設定の最大行数を取得
        maxRw = .Range("tblSetting[#Data]").Rows.Count

        ' 各設定に従い、データを抽出してtblResultに転記
        For rw = 1 To maxRw
            シート名 = .Range("tblSetting[抽出シート名]")(rw) ' 抽出するシート名
            セルアドレス = .Range("tblSetting[抽出セル番号]")(rw) ' 抽出するセルのアドレス
            
            ' 指定されたシートとセルからデータを取得
            転記データ = wb.Worksheets(シート名).Range(セルアドレス)
            
            ' 抽出したデータをtblResultの該当する列に転記
            .Range("tblResult[抽出対象ファイル名]")(lastRw).Offset(0, rw) = 転記データ
        Next rw
    End With

    ' 処理が終わったらブックを閉じる
    wb.Close

End Sub