Fixing Hyperlinks that somehow got changed by a user

[sspatriots]

Hi,

I've had some success with various versions of the code below to fix hyperlinks that somehow get changed by a user. Not sure if they are saving the file to their hard drive and then back to the server to cause this or not. Regardless, I need a way to get this back to the way it was and my code doesn't seem to work. Not sure if I have a missing forward slash or backslash or what or maybe I have them backwards.

Here is what I have tried:

Sub FixPOHyperlinksHH()
  
    Dim wb As Workbook
    Dim ws As Worksheet
    Dim tb As ListObject
    Dim OldStr As String, NewStr As String
    Dim hyp As Hyperlink

    Set wb = ThisWorkbook
    Set ws = wb.ActiveSheet 'Sheets("2023")

'    assumes Table is the first one on the ActiveSheet
    Set tb = ActiveSheet.ListObjects(1)

    ws.Activate

    OldStr = "C:\Users\HHenderson\AppData\Roaming\Microsoft"

    NewStr = "G:\DEManufacturing"

        For Each hyp In tb.ListColumns("PO#").DataBodyRange.Hyperlinks
    
            If InStr(1, hyp.Address, "/") > 0 Then
                hyp.Address = Replace(hyp.Address, OldStr, NewStr)
            
            Else
                hyp.Address = NewStr & "/" & hyp.Address
            End If
    
        Next hyp

End Sub

 

[sspatriots]

Well, I found the code below that seems much simpler and it worked for now....

Public Sub Change_Hyperlinks()



Dim ws As Worksheet

Dim hlink As Hyperlink



For Each ws In ActiveWorkbook.Worksheets

For Each hlink In ws.Hyperlinks

hlink.Address = Replace(hlink.Address, "C:\Users\HHenderson\AppData\Roaming\Microsoft", "G:\DEManufacturing", Compare:=vbTextCompare)

Next

Next



End Sub