Редактирование гиперссылок для фигур

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

Нет необходимости активировать каждый лист, так как ваши "wks" уже указывают на каждый лист.