Question

我在许多工作表中都有数百个超链接的形状。下面的代码非常适合全局更改所有这些工作表的超链接，因为我仅更改了部分超链接。如何使用一系列原始超链接（A2：A300）以及相应的替换范围（B2：B300）更改这些超链接？

Sub FixHyperlinks()
    Dim wks As Worksheet
    For Each Ws In Sheets
    Ws.Activate
    Dim hl As Hyperlink
    Dim sOld As String
    Dim sNew As String
    Set wks = ActiveSheet
    sOld = "part of old address"
    sNew = "replacement to old address"
    For Each hl In wks.Hyperlinks
        hl.Address = Replace(hl.Address, sOld, sNew)
    Next hl
 Next Ws
End Sub

谢谢。

Answer 1

Application.Match能够在列表（范围或数组）中查找值，并返回错误或列表中的位置。

如果找到并更改了超链接，则A列中的相应条目将变为绿色文本。如果未找到超链接，则其工作表的名称和地址将显示在C和D列中。

Sub FixHyperlinks()
    Dim listWS As Worksheet
    Dim currentWS As Worksheet
    Dim hl As Hyperlink
    Dim foundRow As Variant
    Dim writeRow As Long

    Set listWS = ActiveWorkbook.Sheets(1)
    writeRow = 2
    For Each currentWS In ActiveWorkbook.Sheets
        For Each hl In currentWS.Hyperlinks
            foundRow = Application.Match(hl.Address, listWS.Range("A2:A300"), 0)
            If IsNumeric(foundRow) Then
                listWS.Range("A2:A300").Cells(foundRow).Font.Color = vbGreen
                hl.Address = listWS.Range("B2:B300").Cells(foundRow).Value
            Else
                listWS.Cells(writeRow, "C").Value = currentWS.Name
                listWS.Cells(writeRow, "D").Value = hl.Address
                writeRow = writeRow + 1
            End If
        Next hl
    Next currentWS
End Sub

由于您的“工作周”已经指向每个工作表，因此不必激活每个工作表。

编辑形状的超链接

1 个答案: