VBA 功能最强最稳定Excel搜索，实现包含子文件夹内的所有搜索

Sub allSearchRun()
Dim starRow As Long
Dim fileNameList() As String
Dim searchWord As String
Dim folderPath As String
Dim ws As Worksheet
Dim thWB As Workbook
Dim thWS As Worksheet
Dim fileName As String
Dim searchRange As Range
Dim firstFoundCell As Range
Dim foundCell As Range
Dim HiddenMsg As String
Dim filePath As String
Dim StratTime, StopTime As Variant           '// 所需时间
StartTime = Time
starRow = 6
HiddenMsg = ""
Set thWB = ThisWorkbook
Set thWS = thWB.Sheets(1)
folderPath = thWB.Sheets(1).Range("B2").Value
searchWord = thWB.Sheets(1).Cells(3, 2).Value
Dim r As Long
r = 0
Dim tmpList() As String
   tmpList = runDirCMD
    If UBound(tmpList) = 0 Then
          MsgBox "没有发现文件"
          Exit Sub
     End If
For i = LBound(tmpList) To UBound(tmpList)
    If (InStr(tmpList(i), ".xls") > 0) _
            And (InStr(tmpList(i), ".xlsm") = 0) _
            And (InStr(tmpList(i), "~$") = 0) _
            And (InStr(tmpList(i), ".lnk") = 0) Then
        r = r + 1
    End If
Next i
ReDim fileNameList(LBound(tmpList) To r)
r = 1
For i = LBound(tmpList) To UBound(tmpList)
    If (InStr(tmpList(i), ".xls") > 0) _
            And (InStr(tmpList(i), ".xlsm") = 0) _
            And (InStr(tmpList(i), "~$") = 0) _
            And (InStr(tmpList(i), ".lnk") = 0) Then
        fileNameList(r) = tmpList(i)
        r = r + 1
 End If
Next i
Call clearOldRET
thWB.Sheets(2).Cells(1, 1) = "" '异常日志清空
For i = LBound(fileNameList) To UBound(fileNameList)
    If Trim(fileNameList(i)) <> "" Then
            fileName = fileNameList(i)
              Application.DisplayAlerts = False
            Application.AskToUpdateLinks = False
            Call StatusBar(i, UBound(fileNameList))
            thWS.Cells(4, 3) = fileName
            Dim objExcel, wb As Object
            Set objExcel = CreateObject("Excel.Application")
            On Error Resume Next
            Set wb = objExcel.Workbooks.Open(fileName, Password:=vbNullString) '含有密码的计入异常纪录
            errDescription = Err.Description
            errNum = Err.Number
            On Error GoTo 0
              If wb Is Nothing Then
                MsgBox "エラーです!" & errDescription
                GoTo OpenErro
              End If
            On Error Resume Next
            For Each ws In wb.Worksheets  '工作表获取失败时
            On Error GoTo OpenErro
                If Not ws Is Nothing Then
                    filePath = Replace(fileName, wb.Name, "")
                    filePath = Left(filePath, Len(filePath) - 1)
                    Set searchRange = ws.UsedRange
                    If Not searchRange Is Nothing Then
                        If ws.Visible = xlSheetVisible Then
                            HiddenMsg = ""
                        Else
                            HiddenMsg = "被隐藏"
                        End If
                        Set foundCell = searchRange.Find(what:=searchWord, LookIn:=xlValues, Lookat:=xlPart, MatchCase:=False)
                        If Not foundCell Is Nothing Then
                          thWS.Cells(starRow, 3) = foundCell
                            Call allSetHPLink(thWS, thWS.Cells(starRow, 4), filePath, wb.Name, ws.Name, foundCell.Address, HiddenMsg)
                            starRow = starRow + 1
                            Set firstFoundCell = foundCell
                            If Not firstFoundCell Is Nothing Then
                                Do
                                Set foundCell = searchRange.FindNext(foundCell)
                               If Not foundCell Is Nothing Then
                                   If foundCell.Address <> firstFoundCell.Address Then
                                        thWS.Cells(starRow, 3) = foundCell
                                        Call allSetHPLink(thWS, thWS.Cells(starRow, 4), filePath, wb.Name, ws.Name, foundCell.Address, HiddenMsg)
                                        starRow = starRow + 1
                                    End If
                                  Else
                                    GoTo findCelNull
                                End If
                                  Loop Until foundCell Is Nothing Or foundCell.Address = firstFoundCell.Address
                             End If
                        End If
                    End If
                 End If
findCelNull:
            Next ws
            wb.Close saveChanges:=False
            thWS.Cells(4, 3) = ""
            Application.DisplayAlerts = True
            Application.AskToUpdateLinks = True
    End If
OpenErro:
If errDescription <> "" Then '异常纪录
   thWB.Sheets(2).Cells(1, 1) = thWB.Sheets(2).Cells(1, 1) & errDescription & ":" & fileName & " " & Now() & vbCrLf
   errDescription = ""
End If
thWB.Save
Next i
StopTime = Time - StartTime
thWS.Cells(4, 3) = "用时:" & Minute(StopTime) & "分" & Second(StopTime) & "秒" & "" & ""

MsgBox "搜索完了"
Application.StatusBar = False
End Sub
'结果追加超链接
Sub allSetHPLink(thWS As Worksheet, retCell As Range, folderPath As String, fileName As String, sheetName As String, cellAddress As String, HiddenMsg As String)
    Dim linkAddress
    Dim ws As Worksheet
    Set ws = thWS
    linkAddress = folderPath & "\" & fileName
    retCell = fileName & "$" & sheetName
    If HiddenMsg = "" Then
      ws.Hyperlinks.Add Anchor:=retCell, _
       Address:=linkAddress, _
      SubAddress:=sheetName & "!" & cellAddress, _
      TextToDisplay:=fileName & "$" & sheetName & cellAddress
    End If
    
End Sub

'执行子文件夹的文件搜索，返回文件地址列表
Function runDirCMD() As String()
Dim cmd As String
Dim output As String
Dim outputArray() As String
Dim i As Long
Dim buf() As Byte

Dim direPath As String
direPath = ThisWorkbook.Sheets(1).Cells(2, 2)
tmpFile = ThisWorkbook.path & "\temp.txt"
strCmd = "dir /a-d /s /b " & direPath & " >" & Chr(34) & tmpFile & Chr(34)
   With CreateObject("Wscript.Shell")
         .Run "cmd /c" & strCmd, 7, True
    End With
If FileLen(tmpFile) < 1 Then
      ' MsgBox "改文件不存在"
        runDirCMD = Split(StrConv("", vbUnicode), vbCrLf)
        Exit Function
End If
Open tmpFile For Binary As #1
        ReDim buf(1 To LOF(1))
        Get #1, , buf
    Close #1
    Kill tmpFile
  outputArray() = Split(StrConv(buf, vbUnicode), vbCrLf)
    runDirCMD = outputArray()
End Function
'显示进度
Sub StatusBar(curStatus, tatle)
    Dim str As String
    blockCur = Round((curStatus / tatle) * 10)
    leftover = Round((1 - curStatus / tatle) * 10)
    str = Round((curStatus / tatle) * 100) & "% :"
    For i = 0 To blockCur - 1
     str = str & "■"
    Next
    For i = 0 To leftover - 1
     str = str & "□"
    Next
    Application.StatusBar = str
End Sub