フォルダとキーワードを指定してExcelブックを検索して新しいシートに出力する

使用用途

設計書の名称が長く紛らわしい上にバージョン管理がファイル名の後ろについている。
仕様書の名称が業務のJOB名でクラス名や機能名ではないから探しづらい。
しかもシートがやたらと分けられていて20シート超えていて探しにくい。
そんな時に使える（と思って作成

参照シート（シート名：検索シート）

ソース

Sub SearchExcelFilesForKeywords()
    Dim keywordSheet As Worksheet
    Dim searchSheet As Worksheet
    Dim keywordRange As Range
    Dim folderPath As String
    Dim keyword As Variant
    Dim filename As String
    Dim ws As Worksheet
    Dim excelFile As String
    Dim wb As Workbook
    Dim cell As Range
    Dim found As Boolean

    ' キーワードが入力されているシートを取得
    Set keywordSheet = ThisWorkbook.Sheets("検索シート")
    
    ' キーワードが入力されているセルの範囲を取得
    Set keywordRange = keywordSheet.Range("A2:A" & keywordSheet.Cells(keywordSheet.Rows.Count, "A").End(xlUp).Row)
    
    ' 検索結果を出力する新しいシートを作成
    Set searchSheet = ThisWorkbook.Sheets.Add
    searchSheet.Name = "検索結果" + Format(Now(), "YYYYMMDD_HHMMSS")

    ' 検索結果のヘッダーを設定
    With searchSheet
        .Cells(1, 1).Value = "キーワード"
        .Cells(1, 2).Value = "ファイル名"
        .Cells(1, 3).Value = "シート名"
    End With
    
    ' 指定フォルダのパスを取得
    folderPath = keywordSheet.Cells(2, "B").Value
    
    ' 指定フォルダ内のすべてのExcelファイルを検索
    excelFile = Dir(folderPath & "\*.xlsx")
    Do While excelFile <> ""
        ' Excelファイルを開く
        Set wb = Workbooks.Open(folderPath & "\" & excelFile)
        
        ' 各シートを検索
        For Each ws In wb.Sheets
            ' シート内の各セルを検索
            For Each cell In ws.UsedRange.Cells
                ' キーワードが含まれているかどうかをチェック
                For Each keyword In keywordRange
                    If InStr(1, cell.Value, keyword.Value, vbTextCompare) > 0 Then
                        ' キーワードが見つかった場合、検索結果を出力
                        searchSheet.Cells(searchSheet.Cells(searchSheet.Rows.Count, "A").End(xlUp).Row + 1, 1).Value = keyword.Value
                        searchSheet.Cells(searchSheet.Cells(searchSheet.Rows.Count, "B").End(xlUp).Row + 1, 2).Value = excelFile
                        searchSheet.Cells(searchSheet.Cells(searchSheet.Rows.Count, "C").End(xlUp).Row + 1, 3).Value = ws.Name
                        found = True
                        Exit For
                    End If
                Next keyword
                If found Then Exit For
            Next cell
            If found Then
                found = False
            End If
        Next ws
        
        ' 次のExcelファイルを検索
        excelFile = Dir
        wb.Close False
    Loop
    
    ' メッセージボックスを表示
    MsgBox "検索が完了しました。", vbInformation
    
    ' メモリの解放
    Set keywordSheet = Nothing
    Set keywordRange = Nothing
    Set searchSheet = Nothing
    Set ws = Nothing
    Set wb = Nothing
    Set cell = Nothing
End Sub

出力結果

検索するキーワード名を表示対象のファイルとシート名を絞り込めるので

仕様覚える間もなく仕様書を探して調べる必要がある場合に使えると思う。