VBA 多个文件批量搜索文字并将结果添加链接

Sub SearchAndRecordResults()
    Dim targetStr As String
    Dim folderPath As String
    Dim fileName As String
    Dim ws As Worksheet
    Dim cell As Range
    Dim resultRow As Long
    
    ' Get the target string to search for 单元格B2检索内容
    targetStr = ThisWorkbook.Sheets("SEARCH").Range("B2").Value
    
    ' Get the folder path 单元格B1路径
    folderPath = ThisWorkbook.Sheets("SEARCH").Range("B1").Value
    
     ' Check if the folder path exists 确认路径是否存在
    If Dir(folderPath, vbDirectory) = "" Then
        MsgBox "Folder path does not exist", vbExclamation
        Exit Sub
    End If
    Dim fileNum
    
    ' Initialize the row number for recording results 第一条结果记录的起始行数
    resultRow = 6
    
    ' Loop through Excel files in the folder 当前文件夹下的所有文件（*.xls*），屏蔽搜索文件本身
    fileName = Dir(folderPath & "\*.xls*")

'对于如何遍历文件目录下的所有子目录请参照下面的方法遍历子文件夹“VBA 调用CMD的tree命令遍历文件”,本文只满足当前文件目录的查找

    Do While (fileName <> "" And fileName <> "ExcelSearch.xlsm")
        If Not (folderPath & "\" & fileName = ThisWorkbook.FullName) Then
            ' Disable Excel alerts to suppress prompts
            Application.DisplayAlerts = False
            Application.AskToUpdateLinks = False
            ' Open the target workbook and make a copy
            Dim wb As Workbook
            
            On Error Resume Next
            Set wb = Workbooks.Open(folderPath & "\" & fileName, UpdateLinks:=0) ' Open without updating links
           On Error GoTo 0
            If wb Is Nothing Then
                MsgBox "文件无法打开" & folderPath & "\" & fileName
                GoTo endwhile
            End If
            
            ' Restore Excel alerts ’屏蔽打开时警告信息
            Application.DisplayAlerts = True
            Application.AskToUpdateLinks = True
            ' Loop through all worksheets in the workbook 循环遍历所有sheet
            For Each ws In wb.Sheets
                ' Search for the target string in the worksheet
                On Error Resume Next ' Ignore errors temporarily
                For Each cell In ws.UsedRange
                    If IsError(cell) = False Then　‘过滤错误值
                        If InStr(1, cell.Value, targetStr, vbTextCompare) > 0 And cell.Value <> "" Then
                           ' Found a match, record the result 比对结果
                            Dim linkAddress As String
                            linkAddress = folderPath & "\" & fileName & "$" & ws.Name & "!" & cell.Address
                            
                             ThisWorkbook.Sheets("SEARCH").Cells(resultRow, 2).Value = linkAddress
                             ThisWorkbook.Sheets("SEARCH").Cells(resultRow, 3).Value = cell.Value
                                If ws.Visible = xlSheetVisible Then 
                                    ThisWorkbook.Sheets("SEARCH").Hyperlinks.Add _
                                        Anchor:=ThisWorkbook.Sheets("SEARCH").Cells(resultRow, 2), _
                                        Address:=folderPath & "\" & fileName, SubAddress:=ws.Name & "!" & cell.Address, _
                                        TextToDisplay:=linkAddress
                                Else
                                 ThisWorkbook.Sheets("SEARCH").Cells(resultRow, 1).Value = "WorkSheet被隐藏"
                                End If
                            resultRow = resultRow + 1
                            
                        End If
                    End If
                Next cell
                On Error GoTo 0 ' Disable error handling
            Next ws
            
            ' Close the copied workbook without saving changes 关闭并不保存
            wb.Close SaveChanges:=False
            fileNum = fileNum + 1
            ThisWorkbook.Sheets("SEARCH").Cells(resultRow, 1) = fileNum
        End If
        ' Continue to the next file 继续下一个文件
endwhile:
        fileName = Dir

上面代码中Sheet内的搜索用下面Find,和FindNext方法搜索效率更高

Sub FindInEntireWorksheet()
    Dim ws As Worksheet
    Dim searchRange As Range
    Dim foundCell As Range
    Dim firstFoundCell As Range
    Dim searchValue As String
    
    ' 设置要搜索的值
    searchValue = "YourSearchValue"
    
    ' 设置要搜索的工作表
    Set ws = ThisWorkbook.Sheets("Sheet1") ' 修改为你的工作表名称
    
    ' 设置搜索范围为整个工作表
    Set searchRange = ws.UsedRange ' 或者可以使用 ws.Cells，视需求而定
    
    ' 在整个工作表范围内查找第一个匹配项
    Set foundCell = searchRange.Find(What:=searchValue, LookIn:=xlValues, _
                                     LookAt:=xlPart, MatchCase:=False)
    
    ' 如果找到了第一个匹配项，则继续查找下一个匹配项直到回到第一个匹配项为止
    If Not foundCell Is Nothing Then
        Set firstFoundCell = foundCell
        Do
            ' 在这里处理找到的单元格
            Debug.Print "Found at " & foundCell.Address
            
            ' 继续查找下一个匹配项
            Set foundCell = searchRange.FindNext(foundCell)
        Loop Until foundCell Is Nothing Or foundCell.Address = firstFoundCell.Address
    Else
        MsgBox "未找到匹配项。"
    End If
End Sub
 

    Loop
    MsgBox "检索完成，有" & resultRow - 6 & "个文件存在检索内容"
End Sub

以上