Hiromi

 
Sub 検索開始()
    Dim searchString As String
    Dim FolderPath As String

    ' 検索シートから検索文字列とフォルダパスを取得
    searchString = ThisWorkbook.Sheets("検索").Range("B1").Value
    FolderPath = ThisWorkbook.Sheets("検索").Range("B2").Value

    If FolderPath = "" Or searchString = "" Then
        MsgBox "検索する文字列とフォルダパスを入力してください。"
        Exit Sub
    End If

    ' 検索結果シートが存在する場合は削除
    Dim resultSheet As Worksheet
    On Error Resume Next
    Set resultSheet = ThisWorkbook.Sheets("検索結果")
    On Error GoTo 0

    If Not resultSheet Is Nothing Then
        Application.DisplayAlerts = False
        resultSheet.Delete
        Application.DisplayAlerts = True
    End If

    ' 検索結果シートを新規作成
    Set resultSheet = ThisWorkbook.Sheets.Add
    resultSheet.Name = "検索結果"
    resultSheet.Range("B1:G1").Value = Array("検索ワード", "ファイルパス", "ファイル名", "シート名", "セル番号", "セルの値")

    ' フォルダ内の全てのExcelファイルを検索
    Dim rowNum As Long
    rowNum = 2
    SearchFilesInFolder FolderPath, searchString, resultSheet, rowNum
    MsgBox "検索が完了しました。"
End Sub

Sub SearchFilesInFolder(FolderPath As String, searchString As String, resultSheet As Worksheet, ByRef rowNum As Long)
    Dim fso As Object
    Dim folder As Object
    Dim subfolder As Object
    Dim file As Object
    Dim wb As Workbook

    Set fso = CreateObject("Scripting.FileSystemObject")
    Set folder = fso.GetFolder(FolderPath)

    ' フォルダ内の全てのファイルをチェック
    For Each file In folder.Files
        If LCase(fso.GetExtensionName(file.Name)) = "xlsx" Or LCase(fso.GetExtensionName(file.Name)) = "xls" Then
            Set wb = Workbooks.Open(file.Path)
            SearchStringInWorkbook wb, searchString, resultSheet, rowNum, file.Path, file.Name
            wb.Close SaveChanges:=False
        End If
    Next file

    ' サブフォルダ内の全てのファイルを再帰的にチェック
    For Each subfolder In folder.Subfolders
        SearchFilesInFolder subfolder.Path, searchString, resultSheet, rowNum
    Next subfolder
End Sub

Sub SearchStringInWorkbook(wb As Workbook, searchString As String, resultSheet As Worksheet, ByRef rowNum As Long, FilePath As String, FileName As String)
    Dim ws As Worksheet
    Dim cell As Range
    Dim firstAddress As String
    Dim HLink As Hyperlink

    ' 各シートをループ
    For Each ws In wb.Worksheets
        ' 各シートで文字列を検索
        With ws.Cells
            Set cell = .Find(What:=searchString, LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False)
            If Not cell Is Nothing Then
                firstAddress = cell.Address
                Do
                    ws.Hyperlinks.Add Anchor:=resultSheet.Cells(rowNum, 1), _
                          Address:=FilePath, _
                          SubAddress:=ws.Name & "!" & cell.Address, _
                          TextToDisplay:="Link"
                    
                    ' 検索結果を結果シートに書き込み
                    resultSheet.Cells(rowNum, 2).Value = searchString
                    resultSheet.Cells(rowNum, 3).Value = FilePath
                    resultSheet.Cells(rowNum, 4).Value = FileName
                    resultSheet.Cells(rowNum, 5).Value = ws.Name
                    resultSheet.Cells(rowNum, 6).Value = cell.Address
                    resultSheet.Cells(rowNum, 7).Value = cell.Value
                    rowNum = rowNum + 1
                    Set cell = .FindNext(cell)
                Loop While Not cell Is Nothing And cell.Address <> firstAddress
            End If
        End With
    Next ws
End Sub