在工作簿中搜索文本以及指向匹配工作表名称的超链接

Question

我正在尝试搜索 94 个以上的工作表，并在列中搜索超链接文本以匹配工作簿中的工作表。

Sub test()
    Dim mySht As Worksheet, sht As Worksheet
    Dim cell As Range, myRng As Range

    Set mySht = ActiveSheet
    For Each cell In mySht.Range("B7:B200", ["H7:H200"])
        For Each sht In Worksheets
            If sht.Name <> mySht.Name Then    ' find each worksheet except myself
                Set myRng = Nothing
                On Error Resume Next
                Set myRng = sht.Cells.Find(what:=cell.Value, LookIn:=xlValues, lookat:=xlWhole)    ' find match
                If Not myRng Is Nothing Then
                    mySht.Hyperlinks.Add _
                        anchor:=cell, _
                        Address:="", _
                        SubAddress:=myRng.Address(True, True, xlA1, True), _
                        TextToDisplay:=cell.Value
                    Exit For
                End If
                On Error GoTo 0
            End If
        Next sht
    Next cell
End Sub

我发现了两个问题：

1. 我必须一次运行一张。我将工作表更改为

   ThisWorkbook

   并遇到了一些错误。 （第二代码部分）

2. 我在范围内遗漏了一些东西。它不仅仅在单元格 B7:B200 和 H7:H200 上运行，它还超链接 C:G 中的所有内容。

Sub test() 
Dim mySht As ThisWorkbook, sht As ThisWorkbook Dim cell As Range, myRng As Range
Set mySht = ThisWorkbook
For Each cell In mySht.Range("B7:B200", ["H7:H200"])
    For Each sht In ThisWorkbook
        If sht.Name <> mySht.Name Then    ' find each worksheet except myself
            Set myRng = Nothing
            On Error Resume Next
            Set myRng = sht.Cells.Find(what:=cell.Value, LookIn:=xlValues, lookat:=xlWhole)    ' find match
            If Not myRng Is Nothing Then
                mySht.Hyperlinks.Add _
                    anchor:=cell, _
                    Address:="", _
                    SubAddress:=myRng.Address(True, True, xlA1, True), _
                    TextToDisplay:=cell.Value
                Exit For
            End If
            On Error GoTo 0
        End If
    Next sht
Next cell
End Sub

编译错误：找不到方法或数据成员

Answer 1

这是有关如何对代码进行分段以提高可读性的另一个示例。

Option Explicit

Function SearchForSheetName(ByVal shtName As String) As Worksheet
    '--- set the return in case we don't find it
    Set SearchForSheetName = Nothing
    If shtName = "" Then
        Exit Function
    End If
    
    Dim sh As Worksheet
    For Each sh In ThisWorkbook.Worksheets
        If sh.name = shtName Then
            Set SearchForSheetName = sh
            Exit For
        End If
    Next sh
End Function

Sub MainProcess()
    Dim wsWithNames As Worksheet
    Set wsWithNames = ThisWorkbook.Sheets("Sheet1")
    
    With wsWithNames
        Dim nameRange As Range
        Set nameRange = Union(.Range("B7:B200"), .Range("H7:H200"))
        
        Dim nameCell As Range
        For Each nameCell In nameRange
            Debug.Print "nameCell at " & nameCell.Address
            If nameCell.Value <> "" Then
                Dim foundWS As Worksheet
                Set foundWS = SearchForSheetName(nameCell.Value)
                If Not foundWS Is Nothing Then
                    nameCell.Hyperlinks.Add Anchor:=nameCell, _
                                            Address:="", _
                                            SubAddress:="'" & nameCell.Value & "'!A1", _
                                            TextToDisplay:=nameCell.Value
                End If
            End If
        Next nameCell
    End With
End Sub

Answer 2

使用所有工作表中找到的值创建指向单元格的超链接

• 对于目标工作表 (

  Sheet1

  ) 给定范围内的每个值，它将循环遍历所有其他（源）工作表（从左到右的选项卡）并尝试查找该值。如果找到该值，它将用指向找到的单元格的超链接替换目标工作表中的值，并继续搜索下一个值。

Sub GenerateHyperlinks()
    
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containinig this code
    
    Dim dws As Worksheet: Set dws = wb.Sheets("Sheet1") ' !!!
    Dim drg As Range: Set drg = dws.Range("B7:B200,H7:H200")
    drg.Hyperlinks.Delete ' clear existing hyperlinks
    
    Dim sws As Worksheet, scell As Range, dcell As Range
    Dim dValue As Variant, IsValueValid As Boolean

    For Each dcell In drg.Cells
        dValue = dcell.Value
        IsValueValid = False
        If Not IsError(dValue) Then ' no error
            If Len(dValue) > 0 Then IsValueValid = True ' not blank
        End If
        If IsValueValid Then
            For Each sws In wb.Worksheets
                If sws.Name <> dws.Name Then
                    Set scell = sws.UsedRange.Find(What:=dValue, _
                        LookIn:=xlValues, LookAt:=xlWhole)
                    If Not scell Is Nothing Then
                        dws.Hyperlinks.Add _
                            Anchor:=dcell, _
                            Address:="", _
                            SubAddress:="'" & sws.Name & "'!" & scell.Address, _
                            TextToDisplay:=CStr(dValue)
                        Exit For
                    End If
                End If
            Next sws
        End If
    Next dcell

    MsgBox "Hyperlinks generated.", vbInformation

End Sub

Answer 3

• ThisWorkbook

  是保存VBA代码的对象；它不是变量类型，因此不能与

  Dim

  一起使用。
• 我假设

  B7:B200,H7:H200

  在 ActiveSheet 上，如果它在不同的工作表上，请调整。

• ThisWorkbook.Worksheets

  是工作表集合。

Sub test()
    Dim mySht As Worksheet, sht As Worksheet
    Dim cell As Range, myRng As Range
    ' Assume the keyword list is on ActiveSheet
    Set mySht = ActiveSheet
    ' If not, change to
    ' Set mySht = ThisWorkbook.Worksheets("TargetSheetName")
    For Each cell In mySht.Range("B7:B200,H7:H200")
        ' skip blank cells
        If Len(cell.Value) > 0 Then
            ' loop through all worksheets
            For Each sht In ThisWorkbook.Worksheets
                If sht.Name <> mySht.Name Then    ' find each worksheet except myself
                    Set myRng = Nothing
                    On Error Resume Next
                    Set myRng = sht.Cells.Find(what:=cell.Value, LookIn:=xlValues, lookat:=xlWhole)    ' find match
                    On Error GoTo 0 ' enabled error handler
                    If Not myRng Is Nothing Then
                        mySht.Hyperlinks.Add _
                            anchor:=cell, _
                            Address:="", _
                            SubAddress:=myRng.Address(True, True, xlA1, True), _
                            TextToDisplay:=cell.Value
                        Exit For
                    End If
                End If
            Next sht
        End If
    Next cell
End Sub