Attribute VB_Name = "キーワード検索"
Option Explicit

Sub キーワードを検索して出力()
    
    Dim kw As String:  kw = InputBox("ブック検索するキーワードを入力してください。", "キーワード入力")
    If kw = "" Then errorEnd ("キーワードがないので終了します。")
    
    '結果シートを挿入
    Call addDobleDuggerSheet
    
'    Dim tictoc As Double: Call ストップウォッチ(tictoc)
    
    '結果格納用　辞書配列
    Dim Dic:    Set Dic = CreateObject("Scripting.Dictionary")
    
    'アクティブなブックを対象にキーワードを検索し、
    Dim FoundCell As range, FirstCell As range, KeyWord As String, oGyo As Long
    Dim sh As Long, cnt As Long
    For sh = 1 To Worksheets.Count
        Set FoundCell = Worksheets(sh).Cells.Find(What:=kw)
        If Not (FoundCell Is Nothing) Then
            Set FirstCell = FoundCell
            
            'Hitしたら書き込む
            cnt = cnt + 1
            Dic.Add cnt, FoundCell.Parent.Name & "‡" & FoundCell.Address(0, 0) & "‡" & FoundCell.Value
            
            Do
                '次を検索
                Set FoundCell = Worksheets(sh).Cells.FindNext(FoundCell)
                
                'シートに１つしかなかったら抜ける
                If FoundCell Is Nothing Then Exit Do
                
                '検索結果が最初に戻ったら抜ける
                If FoundCell.Address = FirstCell.Address Then Exit Do
                
                'Hitしたら書き込む
                cnt = cnt + 1
                Dic.Add cnt, FoundCell.Parent.Name & "‡" & FoundCell.Address(0, 0) & "‡" & FoundCell.Value
            Loop
        End If
    Next sh
    ''出力
    Cells(1, "F") = "検索キーワード：" & kw
    
    Dim oArr() As Variant:    ReDim oArr(Dic.Count + 1, 4)
    oArr(0, 0) = "��"
    oArr(0, 1) = "シート"
    oArr(0, 2) = "セル"
    oArr(0, 3) = "テキスト"
    Dim Items: Items = Dic.Items
    Dim buf, i As Long
    For i = 0 To Dic.Count - 1
        oArr(i + 1, 0) = i + 1
        buf = Split(Items(i), "‡")
        oArr(i + 1, 1) = buf(0)
        oArr(i + 1, 2) = buf(1)
        oArr(i + 1, 3) = buf(2)
    Next i
    Set Dic = Nothing
    Call ArrayToCell(Cells(1, 1), oArr)
    
    Columns("D").ColumnWidth = 100
    Cells(1, 1).AutoFilter
    Cells(1, 1).CurrentRegion.Borders.LineStyle = xlContinuous
    
    'ストップウォッチ (tictoc)
    MsgBox "キーワード「" & kw & "」で検索した結果、" & Format(cnt, "#,##0") & "件ヒットしました。", vbOKOnly, Format(cnt, "#,##0") & "件ヒット"
    
End Sub

 

 

'2次元配列をシートに貼り付ける便利モジュール
Private Sub ArrayToCell(Target As range, oArr, Optional ColCnt As Long = 0)
    Dim iRowMax:    iRowMax = UBound(oArr, 1) - LBound(oArr, 1) + 1 '// １次元目の要素数を取得 '// 二次元配列の最大行数
    Dim iColMax:    iColMax = UBound(oArr, 2) - LBound(oArr, 2) + 1 '// ２次元目の要素数を取得'// 二次元配列の最大列数
    
    '// Rangeオブジェクトで開始セルから貼り付けるセル範囲を拡張する場合
    If ColCnt > 0 And ColCnt <= iColMax Then
        Target.Resize(iRowMax, ColCnt).Value = oArr
    Else
        Target.Resize(iRowMax, iColMax).Value = oArr
    End If
End Sub

 

Private Sub addDobleDuggerSheet()
    '‡シートを挿入。すでにあれば確認のうえ上書き
    If Worksheets(Worksheets.Count).Name = "‡" Then
        If MsgBox("検索結果を更新しますか？", vbOKCancel) = vbCancel Then End
        Application.DisplayAlerts = False
        Worksheets(Worksheets.Count).Delete
        Application.DisplayAlerts = True
    End If
    Sheets.Add after:=Worksheets(Worksheets.Count)
    ActiveSheet.Name = "‡"

 

End Sub

Private Sub ストップウォッチ(ByRef tictoc)
    If tictoc = 0 Then
        tictoc = Timer
    Else
        Debug.Print "[" & Now & "] "; Format(Timer - tictoc, "0.00秒")
        tictoc = Timer
    End If
End Sub

Private Sub errorEnd(msg)
    MsgBox msg
    End
End Sub