VBAでフォルダを指定してエクセルファイル内の文字列を検索

Option Explicit
Dim myWB As Workbook
Dim varArray As Variant
Dim myStr As Variant
Dim targetFolder As String
Dim fso As Object

Sub フォルダ指定文字列検索()

Application.ScreenUpdating = False
Application.EnableEvents = False

Call 文字入力
varArray = Array(myStr)

'フォルダの指定
Dim strDirPath As String
'フォルダの選択
With Application.FileDialog(msoFileDialogFolderPicker)
    If .Show = True Then targetFolder = .SelectedItems(1)
End With
If Len(targetFolder) = 0 Then End

Call Add_myBook

Set fso = CreateObject("Scripting.fileSystemObject")

'対象フォルダ配下（サブフォルダ）の全ファイルに対する処理（再起処理）
Call loopAllFiles(targetFolder, fso)

Set fso = Nothing

'イベント抑止を解除
Application.EnableEvents = True
'画面更新の停止
Application.ScreenUpdating = True

myWB.Worksheets(1).Columns("A:C").AutoFit

MsgBox prompt:="処理が終了しました。"

End Sub

'対象フォルダ配下（サブフォルダ）の全ファイルに対する処理（再起処理）
Private Function loopAllFiles(targetFolder As String, fso As Object)

Const FILE_TYPE_XLSX As String = "xlsx"
Const FILE_TYPE_XLS As String = "xls"

Dim folder As Object
Dim file As Object

'サブフォルダの数だけ再帰
For Each folder In fso.GetFolder(targetFolder).SubFolders
    Call loopAllFiles(folder.Path, fso)
    'ここでdebugしておくとイミディエイトウィンドウで幸せになれる
    debug.print folder.path
Next folder

'ファイルの数分繰り返し
For Each file In fso.GetFolder(targetFolder).Files

    Dim extentionName As String
    extentionName = fso.GetExtensionName(file.Name)
    
    If LCase(extentionName) = FILE_TYPE_XLSX Or LCase(extentionName) = FILE_TYPE_XLS Then
        'Excelファイルに対する処理
        Call execExcelFile(file)
    End If
    
Next file

End Function

'Excelファイルに対する処理
Private Function execExcelFile(file As Object)

Dim wkbook As Workbook

On Error Resume Next
Set wkbook = Workbooks.Open(Filename:=file.Path, UpdateLinks:=0, corruptload:=xlRepairFile, Password:="", IgnoreReadOnlyRecommended:=True, ReadOnly:=True)

Debug.Print wkbook.Name
Call Books_Find_Main(wkbook)

End Function
Private Sub Add_myBook()
  Set myWB = Workbooks.Add
  With myWB.Worksheets(1)
    .Cells(1, 1).Value = "検索文字列:" & Join$(varArray, ",")
    .Cells(2, 1) = targetFolder
    .Cells(3, 1).Resize(, 4).Value = Array("フォルダパス", "ブック名", "シート名", "セルアドレス")
  End With
End Sub
  Private Sub Books_Find_Main(WB As Workbook) 'ブック内全シートの検索
    Dim v As Variant, strAddress As String
    Dim Sh As Worksheet, rngFnd As Range, rngUni As Range
    
    With WB
        .Activate
        For Each Sh In .Worksheets
            For Each v In varArray
                Set rngFnd = Sh.Cells.Find(What:=v, LookAt:=xlPart) '検索
                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.FullName           
                    .Hyperlinks.Add Anchor:=.Offset(0), Address:=WB.Path, TextToDisplay:=WB.Path
                    .Hyperlinks.Add Anchor:=.Offset(, 1), Address:=WB.FullName, TextToDisplay:=WB.Name
                    .Offset(, 2).Value = Sh.Name
                    .Offset(, 3).Value = rngUni.Address(False, False)
                End With
                Set rngUni = Nothing
            End If
        Next
        .Close SaveChanges:=False
    End With
End Sub

Sub 文字入力()

inputKensaku:
    On Error GoTo ErrHandle
    
    myStr = InputBox(prompt:="検索する文字を入力してください", Title:="検索文字列入力")
    
    If Len(myStr) = 0 Then
    End
    
    End If
    
    Exit Sub
    
ErrHandle:
    MsgBox Err.Description & String(2, vbCrLf) & "再度入力してください", vbCritical
    Resume inputKensaku
    
End Sub