Editing Hyperlinks for shapes

Question

I have hundreds of shapes hyperlinked in numerous worksheets. The code below worked great to globally change the hyperlinks of all of these worksheets because I was only changing part of the hyperlink. How do I change these hyperlinks using a range of original hyperlinks (A2:A300), with a corresponding replacement range(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

Thank you.

I don‘t understand your question. Do you have a list of 299 different old/new combinations of URLs? And you still want to change every hyperlink on every sheet? — Asger, Apr 27 '19 at 16:45
Yes, I have new URL,s. I do not need to change every hyperlink on every sheet. I just need to change the hyperlinks that are in my A2:A300 list with a replacement from my B2:B300 list. For instance hyperlink in A2 would be replaced with a hyperlink in B2. A32 with B32 etc... — needler, Apr 27 '19 at 17:22
The A2:A300 hyperlinks are found on the existing shapes in the worksheets. The B2:B300 will be their replacements. — needler, Apr 27 '19 at 18:32

Asger · Accepted Answer · 2019-05-01T15:29:52.403

Application.Match is able to find values in a list (range or array) and returns either an error or the position within that list.

If a hyperlink is found & changed, then the corresponding entry in column A becomes green text. If a hyperlink is not found, its worksheet's name and its address are shown in column C and 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

It is not necessary to activate each worksheet, as your "wks" already points to each sheet.

The above worked great in finding and replacing the hyperlinks on my shapes. How can I find the hyperlinks on the shapes that did not get changed because they where not on the B2:B300 list? They would be the hyperlinks that where 61 characters long. — needler, May 01 '19 at 09:03
This method can be used to get a list of all of the hyperlinks on the worksheets or to troubleshoot errors by adjusting the A2:A300 and B2:B300 data ranges to a smaller sampling as changes take place ( i.e A2:A15 and B2:B15 would be edited hyperlinks needing changed) I reran 2-3 times until all hyperlinks where changed and my range was A2:A3 & B2:B3. The C and D columns then returned all of the hyperlinks for the shapes based on the worksheet name. You can verify your work easily as a simple sort of the column will spot any rouge links. This code answered my question completely! — needler, May 10 '19 at 06:45

Editing Hyperlinks for shapes

1 Answers1