Dim resSearchFolderCnt As Long
Dim resSearchFolderPath(128) As String


Public Sub ExtractExcelData()
    Dim FileKeyword As String
    Dim FolderPath As String
    Dim InSeetNo As Integer
    Dim InCellArea As String
    Dim InRowSize As Integer
    Dim OutSeetNo As Integer
    Dim OutCell As String
    Dim OutPathCol As String
    
    '変数データ取り込み
    With ThisWorkbook.Sheets(1)
        FileKeyword = .Range("B4") '検索キーワード
        FolderPath = .Range("C4") '検索対象パス
        
        InSeetNo = .Range("D4") '検索シートNo
        InCellArea = .Range("E4") '取り込み対象セル範囲
        InRowSize = .Range("F4") '取り込み対象セル範囲の行数
        
        OutSeetNo = .Range("G4") '出力シートNo
        OutCell = .Range("H4") '出力対象先頭セル
        OutPathCol = .Range("I4") 'ファイルパスを出力する列
    End With
        
    'FolderPath以下のサブフォルダをresSearchFolderPathに格納、resSearchFolderCnt更新
    setSearchFolderPath (FolderPath)
    
    
    Dim path As String
    Dim var As Variant
    Dim DirResult As String
    Dim MaxRow As Long
    Dim MaxCol As Long
    Dim OutPathArea As String
    Dim OutPathRow As Integer
    Dim OutCellCol As String
    Dim OutCellRow As Integer
    Dim OutCellNow As String
    Dim FileCnt As Integer
    
    FileCnt = 0
    OutCellCol = Left(OutCell, 1)
    OutCellRow = Right(OutCell, 1)
    
    Dim fCnt As Variant
    fCnt = 0
    
    Do While (fCnt < resSearchFolderCnt)
        
        'pathの最後が\でないなら追加する
        path = resSearchFolderPath(fCnt)
        If Right(path, 1) <> "\" Then
            path = path & "\"
        End If
        
        'path内でFileKeywordに合うファイルのリストを取得する
        DirResult = Dir(path & FileKeyword)
    
        Do While (DirResult <> "")
            'シートのデータを取り込み
            var = getExcelFileData(path & DirResult, InSeetNo, InCellArea)
            MaxRow = UBound(var, 1)
            MaxCol = UBound(var, 2)
        
            '指定したセルへ貼り付け
            OutCellNow = OutCellCol & (OutCellRow + InRowSize * FileCnt)
            ThisWorkbook.Sheets(OutSeetNo).Range(OutCellNow).Resize(MaxRow, MaxCol) = var
        
            '指定列にファイルパスを貼り付け
            OutPathRow = Right(OutCell, 1)
            OutPathArea = OutPathCol & (OutPathRow + InRowSize * FileCnt) & ":" & OutPathCol & (OutPathRow + InRowSize - 1 + InRowSize * FileCnt)
    
            ThisWorkbook.Sheets(OutSeetNo).Range(OutPathArea) = path & DirResult
        
        
            DirResult = Dir 'カウントアップ
            FileCnt = FileCnt + 1 'カウントアップ
        Loop
        
        fCnt = fCnt + 1 'サブフォルダリストカウントアップ
    Loop
    
End Sub


Public Sub setSearchFolderPath(ByVal FolderPath As String)
    '先頭フォルダを追加
    resSearchFolderPath(0) = FolderPath
    resSearchFolderCnt = 1
    
    'サブフォルダを追加
    SearchFolderPath (FolderPath)

End Sub


Public Function SearchFolderPath(ByVal FolderPath As String)
    Dim buf As String
    Dim f As Object
    
    buf = Dir(FolderPath & "\*.*")
    
    With CreateObject("Scripting.FileSystemObject")
        For Each f In .GetFolder(FolderPath).SubFolders
            Call SearchFolderPath(f.path)
            
            resSearchFolderPath(resSearchFolderCnt) = f.path
            resSearchFolderCnt = resSearchFolderCnt + 1
        Next f
    
    End With

End Function


'FilePathのエクセルファイルの、SeetNoのシートの、CellArea部分を取得する
Public Function getExcelFileData(ByVal FilePath As String, ByVal SeetNo As Integer, ByVal CellArea As String)
    Dim wb As Workbook
    Dim ws As Worksheet
    Dim data As Variant
    
    'MsgBox FilePath

    Set wb = Workbooks.Open(FilePath) 'ワークブックを開く
    Set ws = wb.Worksheets(SeetNo) 'ワークシートを参照する
    
    getExcelFileData = ws.UsedRange.Range(CellArea) 'CellArea部分を取得して返す

    wb.Close 'ワークブックを閉じる
    Set ws = Nothing 'メモリの開放
    Set wb = Nothing 'メモリの開放

End Function