Dim resSearchFolderCnt As Long
Dim resSearchFolderPath(128) As String


Public Sub InsertThumbnails()
    Dim FileKeyword As String
    Dim folderPath As String
    Dim InSeetNo As Integer
    Dim LinkOrDirect 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
        LinkOrDirect = .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 img As Object
    Dim shp As Shape
    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 <> "")
        
            If LinkOrDirect = "link" Then
                'シートのデータを取り込み(1)リンク保持''''''''''''''''''''''''''''''''''
                Set img = ThisWorkbook.Sheets(OutSeetNo).Pictures.Insert(path & DirResult)
                With img
                    .Left = ThisWorkbook.Sheets(OutSeetNo).Cells(OutCellRow + FileCnt, OutCellCol).Left
                    .Top = ThisWorkbook.Sheets(OutSeetNo).Cells(OutCellRow + FileCnt, OutCellCol).Top
                    .Width = ThisWorkbook.Sheets(OutSeetNo).Cells(OutCellRow + FileCnt, OutCellCol).ColumnWidth - 1
                    .Height = ThisWorkbook.Sheets(OutSeetNo).Cells(OutCellRow + FileCnt, OutCellCol).RowHeight - 1
                End With
                ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
            Else
                'シートのデータを取り込み(2)画像を直接保存''''''''''''''''''''''''''''''
                Set shp = ThisWorkbook.Sheets(OutSeetNo).Shapes.AddPicture(filename:=path & DirResult, _
                    LinkToFile:=False, _
                    SaveWithDocument:=True, _
                    Left:=ThisWorkbook.Sheets(OutSeetNo).Cells(OutCellRow + FileCnt, OutCellCol).Left, _
                    Top:=ThisWorkbook.Sheets(OutSeetNo).Cells(OutCellRow + FileCnt, OutCellCol).Top, _
                    Width:=-1, _
                    Height:=-1)
                With shp
                    .LockAspectRatio = msoTrue  ' 縦横比の固定
                    .Height = ThisWorkbook.Sheets(OutSeetNo).Cells(OutCellRow + FileCnt, OutCellCol).RowHeight - 1 '画像の高さを調整
                End With
                ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
            End If
        
            '指定列にファイルパスを貼り付け
            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