You Look Too Cool

Const resultsn = "検索結果"
Dim gyo As Long

Sub 複数ファイルシート一括検索()
    Dim myfolder, myfn, myword
    myword = InputBox("検索文字列を入力")
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "フォルダを選択"
        .AllowMultiSelect = False
        If .Show = -1 Then
            myfolder = .SelectedItems(1)
        Else
            Exit Sub
        End If
    End With
    myfn = Dir(myfolder & "\*.xls", vbNormal)
    Sheets(resultsn).Select
    Cells.ClearContents
    Cells(1, 1) = "ファイル名"
    Cells(1, 2) = "シート名"
    Cells(1, 3) = "セルの内容"
    Cells(1, 4) = "リンク"
    gyo = 2
    Do Until myfn = ""
        Call ファイルを検索(myfolder, myfn, myword)
        myfn = Dir
    Loop
    Sheets(resultsn).Select
End Sub

Function ファイルを検索(myfolder, myfn, myword)
    Dim mysheet
    Dim basefn, mysn, myadress As String
    Dim kekka
    Dim firstaddress As String
    basefn = ThisWorkbook.Name
    Workbooks.Open Filename:=myfn
    For Each mysheet In Worksheets
        mysn = mysheet.Name
        Set kekka = mysheet.Cells.Find(myword)
        If Not kekka Is Nothing Then
            firstaddress = kekka.Address
            Do
                myadress = myfolder & "\" & myfn & "#" & mysn & "!" & kekka.Address
                With Workbooks(basefn).Sheets(resultsn)
                    .Cells(gyo, 1) = myfn
                    .Cells(gyo, 2) = mysn
                    .Cells(gyo, 3) = kekka.Value
                    .Hyperlinks.Add Anchor:=.Range("D" & gyo), _
                        Address:=myadress, _
                        TextToDisplay:=kekka.Address
                End With
                gyo = gyo + 1
                Set kekka = mysheet.Cells.FindNext(kekka)
            Loop While Not kekka Is Nothing And kekka.Address <> firstaddress
        End If
    Next
    Workbooks(myfn).Close
End Function