编辑形状的超链接

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 能够在列表（范围或数组）中找到值，并且 returns 错误或该列表中的位置。

如果找到并更改了超链接，则 A 列中的相应条目将变为绿色文本。如果未找到超链接，其作品sheet 的名称和地址将显示在 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

没有必要激活每个作品sheet，因为你的"wks"已经指向每个sheet。

编辑形状的超链接

Editing Hyperlinks for shapes

excel

vba

hyperlink

shapes