在多工作簿中查找字符串并为结果添加跳转超链接

我有一个VBA宏，能在指定文件夹的多个工作簿中搜索指定字符串，并生成包含工作簿名称、工作表名称、单元格地址和单元格内容的结果列表，目前运行正常。现在需要给结果列表的C列（单元格地址列）添加可点击的超链接，点击后直接跳转到对应的工作簿、工作表及目标单元格。

修改后的完整代码 #

Sub SearchFolders()

Dim fso As Object
Dim fld As Object
Dim strSearch As String
Dim strPath As String
Dim strFile As String
Dim wOut As Worksheet
Dim wbk As Workbook
Dim wks As Worksheet
Dim lRow As Long
Dim rFound As Range
Dim strFirstAddress As String

On Error GoTo ErrHandler
Application.ScreenUpdating = False

' 按需修改搜索路径
strPath = "c:\MyFolder"
strSearch = Range("H2")

' H2是输入搜索字符串的单元格
Set wOut = Worksheets.Add(after:=ActiveWorkbook.Worksheets(ActiveWorkbook.Worksheets.Count))
lRow = 1
With wOut
    .Cells(lRow, 1) = "Workbook"
    .Cells(lRow, 2) = "Worksheet"
    .Cells(lRow, 3) = "Cell"
    .Cells(lRow, 4) = "Text in Cell"
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set fld = fso.GetFolder(strPath)

    strFile = Dir(strPath & "\*.xls*")
    Do While strFile <> ""
        Set wbk = Workbooks.Open _
          (Filename:=strPath & "\" & strFile, _
          UpdateLinks:=0, _
          ReadOnly:=True, _
          AddToMRU:=False)

        For Each wks In wbk.Worksheets
            Set rFound = wks.UsedRange.Find(strSearch)
            If Not rFound Is Nothing Then
                strFirstAddress = rFound.Address
            End If
            Do
                If rFound Is Nothing Then
                    Exit Do
                Else
                    lRow = lRow + 1
                    .Cells(lRow, 1) = wbk.Name
                    .Cells(lRow, 2) = wks.Name
                    ' 替换原单元格地址赋值，改为添加超链接
                    .Hyperlinks.Add Anchor:=.Cells(lRow, 3), _
                                    Address:=strPath & "\" & wbk.Name, _
                                    SubAddress:="'" & wks.Name & "'!" & rFound.Address, _
                                    TextToDisplay:=rFound.Address
                    .Cells(lRow, 4) = rFound.Value
                End If
                Set rFound = wks.Cells.FindNext(after:=rFound)
            Loop While strFirstAddress <> rFound.Address
        Next

        wbk.Close (False)
        strFile = Dir
    Loop
    .Columns("A:D").EntireColumn.AutoFit
End With
MsgBox "Done"

ExitHandler:
Set wOut = Nothing
Set wks = Nothing
Set wbk = Nothing
Set fld = Nothing
Set fso = Nothing
Application.ScreenUpdating = True
Exit Sub

ErrHandler:
MsgBox Err.Description, vbExclamation
Resume ExitHandler

End Sub

关键代码说明 #

使用Excel VBA的Hyperlinks.Add方法实现跳转，参数说明：

• Anchor：指定要添加超链接的单元格（即结果列表的C列对应行）
• Address：目标工作簿的完整路径（包含文件名）
• SubAddress：目标工作表和单元格的地址，格式为'工作表名称'!单元格地址，带单引号可避免工作表名称含特殊字符时出错
• TextToDisplay：超链接显示的文本，这里用目标单元格的地址

内容的提问来源于stack exchange，提问作者David Kurzman