トップ　>　汎用コード　>　指定フォルダの全ブック対象に一括検索

'///宣言セクション///
Dim myWB     As Workbook
Dim varArray As Variant
'///

Sub All_Books_FIND() 'メイン

    varArray = Array("富山", "神奈川") '検索文字列

    Dim strDirPath As String
    'フォルダの選択
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show = True Then strDirPath = .SelectedItems(1)
    End With
    If Len(strDirPath) = 0 Then Exit Sub
    'フォルダの存在確認
    If Dir(strDirPath, vbDirectory) = "" Then Exit Sub
    'フォルダ内ブック検索処理
    Call Search_Books_f(strDirPath)
End Sub

Private Sub Search_Books_f(ByVal strPath As String) 'フォルダ内ブック検索
    Dim strTarget  As String
    Dim strDirPath As String
    With Application
        strPath = strPath & .PathSeparator  'フォルダパスにフォルダ区切り文字追加
        strTarget = Dir(strPath & "*.xls?") 'フォルダ内のExcelブックを検索
        If strTarget = "" Then Exit Sub     'ブックがなければ終了
        .ScreenUpdating = False             '画面更新停止
        .DisplayAlerts = False              '確認メッセージ非表示
        Call Add_myBook                     '書き込み用ブック作成
        On Error Resume Next
            Do
                Call Books_Find_Main(.Workbooks.Open(strPath & strTarget)) 'ブックを開き置換処理
                strTarget = Dir()           '次のExcelブックを検索
            Loop Until strTarget = ""       'ブックがなければループから抜ける
        On Error GoTo 0
        .DisplayAlerts = True
        .ScreenUpdating = True
    End With
    strTarget = Dir("")
    myWB.Worksheets(1).Columns("A:C").AutoFit
    Set myWB = Nothing
End Sub

Private Sub Add_myBook()
    Set myWB = Workbooks.Add
    With myWB.Worksheets(1)
        .Cells(1, 1).Value = "検索文字列：" & Join$(varArray, ",")
        .Cells(2, 1).Resize(, 3).Value = Array("ブック名", "シート名", "セルアドレス")
    End With
End Sub

Private Sub Books_Find_Main(WB As Workbook) 'ブック内全シートの検索
    Dim v          As Variant
    Dim strAddress As String
    Dim Sh         As Worksheet
    Dim rngFnd     As Range
    Dim rngUni     As Range
    
    With WB
        .Activate
        For Each Sh In .Worksheets
            For Each v In varArray
                Set rngFnd = Sh.Cells.Find(What:=v,  _
                                           LookIn:=xlValues,  _
                                           LookAt:=xlPart,  _
                                           SearchOrder:=xlByColumns,  _
                                           MatchCase:=False,  _
                                           MatchByte:=False) '検索
                If Not rngFnd Is Nothing Then
                    strAddress = rngFnd.Address '最初に検索一致したセルのアドレス格納
                    If rngUni Is Nothing Then Set rngUni = rngFnd
                    Do
                        Set rngUni = Union(rngUni, rngFnd)  'セルを集合
                        Set rngFnd = Sh.Cells.FindNext(rngFnd) '次を検索
                    Loop Until strAddress = rngFnd.Address
                End If
            Next
            If Not rngUni Is Nothing Then
                With myWB.Worksheets(1).Cells(Rows.Count, 1).End(xlUp).Offset(1)
                    .Value = WB.Name
                    .Offset(, 1).Value = Sh.Name
                    .Offset(, 2).Value = rngUni.Address(False, False)
                End With
                Set rngUni = Nothing
            End If
        Next
        .Close
    End With
End Sub