トップ　>　汎用コード　>　開いている全ブック対象に一括検索

'--------------------------------------------------------
' 開いている全てのブックから任意の文字列を検索する
'--------------------------------------------------------
'［作成日］2024.11.17
' https://excel.syogyoumujou.com/vba/find_openbooks.html
'--------------------------------------------------------
Sub searchAllTheOpenBooksForAnyString()
    '--------------------------------
    ' 検索する文字列を配列として設定
    '--------------------------------
    Dim varArray As Variant
    varArray = Array("奈良市", "鎌倉市") ' 検索文字列

    '--------------------------------
    ' アプリケーション設定
    '--------------------------------
    Application.ScreenUpdating = False   ' 画面更新無効
    Application.EnableEvents = False     ' イベント無効

    '--------------------------------
    ' 書き込み用新規ブック追加
    '--------------------------------
    Dim shtWrite As Worksheet            ' 新規ブック書き込み用シート
    Set shtWrite = Workbooks.Add.Worksheets(1)

    '--------------------------------
    ' ブック内から文字列を検索
    '--------------------------------
    Dim bokTarget As Workbook
    Dim shtTarget As Worksheet
    Dim rngTarget As Range
    Dim rng       As Range
    Dim varWhat   As Variant
    Dim lngCount  As Long
On Error Resume Next
    For Each bokTarget In Workbooks
        ' 書き込み用新規ブックは対象外
        If bokTarget.Name <> shtWrite.Parent.Name Then
            '--------------------------------
            ' ブックの各シートで検索を実行
            '--------------------------------
            For Each shtTarget In bokTarget.Worksheets
                For Each varWhat In varArray
                    ' 対象シートの全てのセルから任意の文字列を検索
                    Set rngTarget = findTargetCell(shtTarget.Cells, varWhat)
                    
                    ' 検索に一致するセルが存在する場合は新規ブックに情報を書き込み
                    If Not rngTarget Is Nothing Then
                        For Each rng In rngTarget
                            shtWrite.Cells(6 + lngCount, "A").Resize(1, 4).Value _
                                = Array(bokTarget.Name, shtTarget.Name, rng.Address(0, 0), rng.Value)
                            lngCount = lngCount + 1
                        Next
                    End If
                Next
            Next
        End If
    Next
On Error GoTo 0

    '--------------------------------
    ' 検索値が見つからなければ終了
    '--------------------------------
    If lngCount = 0 Then
        shtWrite.Parent.Close SaveChanges:=False
        MsgBox "検索値は見つかりませんでした", vbInformation
        GoTo LBL_FINALLY
    End If

    '--------------------------------
    ' 書き込み用新規ブック見出し設定
    '--------------------------------
    shtWrite.Range("A1:B1").Value = Array("検索日時", Now())
    shtWrite.Range("A3:B3").Value = Array("検索値", Join$(varArray, ","))
    shtWrite.Range("A5:D5").Value = Array("ブック名", "シート名", "セルアドレス", "値")
    shtWrite.Columns("A:C").AutoFit      ' A～C列を自動調整する
    shtWrite.Columns("D:D").ColumnWidth = 100
    shtWrite.Range("A1,A3,A5:D5").Interior.Color = RGB(217, 217, 217)
    
LBL_FINALLY:
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub

'-------------------------------------------------------------------------------------
' 対象セル範囲から任意の文字列を検索するプロシージャ
'-------------------------------------------------------------------------------------
'［引数］
'   rngTarget      ：対象セル範囲
'   What           ：検索する文字列
'   LookIn         ：情報種類　値：xlValues[既定]　数式：xlFormulas　コメント文：xlComments
'   LookAt         ：一致の種類    部分一致：xlPart[既定]　全体一致：xlWhole
'   SearchOrder    ：検索方法   1行ごと検索：xlByRows[既定]　1列ごと検索：xlByColumns
'   SearchDirection：検索順  一致する次の値：xlNext[既定]　一致する前の値：xlPrevious
'   MatchCase      ：大文字・小文字の区別  区別する：True　区別しない：False[既定]
'   MatchByte      ：全角・半角の区別      区別する：True　区別しない：False[既定]
'［戻り値］
'   検索値のセルの集合　検索値がない場合はNothing
'［作成日］2023.12.19　［更新日］2024.11.14
' https://excel.syogyoumujou.com/vba/find_allbooks.html
'-------------------------------------------------------------------------------------
Function findTargetCell(ByRef rngTarget As Range, _
                        ByVal What As String, _
               Optional ByVal LookIn As XlFindLookIn = xlValues, _
               Optional ByVal LookAt As XlLookAt = xlPart, _
               Optional ByVal SearchOrder As XlSearchOrder = xlByRows, _
               Optional ByVal SearchDirection As XlSearchDirection = xlNext, _
               Optional ByVal MatchCase As Boolean = False, _
               Optional ByVal MatchByte As Boolean = False) As Range
    ' 検索セル範囲を最適化
    Set rngTarget = Intersect(rngTarget, rngTarget.Worksheet.UsedRange)
    If rngTarget Is Nothing Then Exit Function
    
    ' 検索実行
    Dim rngFind As Range
    Set rngFind = rngTarget.Find(What, , LookIn, LookAt, SearchOrder, SearchDirection, MatchCase, MatchByte)
    
    ' 検索に一致のセルがない場合
    If rngFind Is Nothing Then
        ' ※ 結合セルで検索に一致しないケースがあるため その対策処理
        If SearchOrder = xlByRows Then SearchOrder = xlByColumns Else SearchOrder = xlByRows
        Set rngFind = rngTarget.Find(What, , LookIn, LookAt, SearchOrder, SearchDirection, MatchCase, MatchByte)
        If rngFind Is Nothing Then Exit Function
    End If
    
    Dim strAddress As String
    Dim rngUnion   As Range
    strAddress = rngFind.Address                  '最初に検索一致したセルのアドレスを取得
    Set rngUnion = rngFind
    Do
        Set rngUnion = Union(rngUnion, rngFind)   'セルを集合
        Set rngFind = rngTarget.FindNext(rngFind) '次の一致セルを検索
        If rngFind Is Nothing Then Exit Do
    Loop Until strAddress = rngFind.Address       'セルアドレスが最初のセルと同じ場合はループを抜ける
    
    Set findTargetCell = rngUnion
End Function