Finding and replacing formulae with Hyperlinks (referencing another worksheet within the workbook)

[CeeB1]

I need to change a value within the formulae to reflect another worksheet. These hyperlinks are jumping to different worksheets within the SAME workbook and I need to be able to change the worksheet name to which it need to jump to (for multiple hyperlinks). The find and replace function for that specific test within the Hyperlink formulae does not work when it refers to another worksheet within the workbook - I have seen solutions to change an external web address which is not what I need.

 

[Toadstool]

Good job GWteB!
You still need to Find/Replace the displayed tab name but it worked perfectly redirecting to BUD2022 on the test sheet I've been playing with.

 

[GWteB]

@Toadstool, thanks for the compliment.
Btw, I assumed that the new worksheets already existed. At least that impression was given by the screenshot in post #5.

 

[CeeB1]

@Toadstool, thanks for the compliment.
Btw, I assumed that the new worksheets already existed. At least that impression was given by the screenshot in post #5.

Thank you so very much, I am getting there and it is such a relief. Can you perhaps advise me on how to only effect these changes within the selected range as opposed on the whole sheet?

 

[GWteB]

Your additional query requires an additional procedure.
Fyi, my previously posted code is not limited to one worksheet, but affects all worksheets in the same workbook that contain one or more hyperlinks.
Note that the new procedure is dependent on some separate functions as well.
For completeness I will post all relevant code.

Public Sub CeeB1()
    
    ' == USAGE EXAMPLES ==
    '                      workbook,    old    ,    new
   'RelinkAllHyperlinks ThisWorkbook, "ACT 2022", "BUD 2022"
   'RelinkAllHyperlinks ActiveWorkbook, "ACT 2022", "BUD 2022"
   
    '                          ----------- range ------------- ,    old    ,    new
   'RelinkSelectedHyperlinks Sheets("Sheet1").Range("A1:BC200"), "ACT 2022", "BUD 2022"
   
    RelinkSelectedHyperlinks Selection, "ACT 2022", "BUD 2022"

End Sub


Public Sub RelinkAllHyperlinks(ByVal argWb As Workbook, ByVal argOldRefName As String, ByVal argNewRefName As String)
    Dim Sht As Worksheet, Hl As Hyperlink
    For Each Sht In argWb.Worksheets
        For Each Hl In Sht.Hyperlinks
            ApplyRelink Hl, argOldRefName, argNewRefName
        Next Hl
    Next Sht
End Sub

Public Sub RelinkSelectedHyperlinks(ByVal argRng As Range, ByVal argOldRefName As String, ByVal argNewRefName As String)
    Dim Sht As Worksheet, Hl As Hyperlink, Anchor As Range
    Set Sht = argRng.Parent
    For Each Hl In Sht.Hyperlinks
        On Error Resume Next
        Set Anchor = Hl.Range
        On Error GoTo 0
        If Not Anchor Is Nothing Then
            If Not Application.Intersect(argRng, Anchor) Is Nothing Then
                ApplyRelink Hl, argOldRefName, argNewRefName
            End If
        End If
    Next Hl
End Sub

Public Sub ApplyRelink(ByRef argHl As Hyperlink, ByVal argOldRefName As String, ByVal argNewRefName As String)
    If VBA.InStr(1, argHl.SubAddress, ShtNameFromRef(argOldRefName), vbTextCompare) > 0 Then
        If WorksheetExists(argHl.Parent.Parent.Parent, ShtNameFromRef(argNewRefName)) Then
            argHl.SubAddress = VBA.Replace(argHl.SubAddress, BuildRef(argOldRefName), BuildRef(argNewRefName), , , vbTextCompare)
        End If
    End If
End Sub

Public Function ShtNameFromRef(ByVal argRefName As String) As String
    ShtNameFromRef = VBA.Split(VBA.Replace(argRefName, "'", ""), "!")(0)
End Function

Public Function BuildRef(ByVal argRefName As String) As String
    argRefName = VBA.Replace(argRefName, "'", "")
    BuildRef = VBA.IIf(VBA.InStr(1, argRefName, " ") > 0, "'" & VBA.Replace(argRefName, "!", "'!"), argRefName)
End Function

Public Function WorksheetExists(ByVal argWb As Workbook, ByVal argShtName As String) As Boolean
    On Error Resume Next
    WorksheetExists = Not argWb.Worksheets(argShtName) Is Nothing
End Function

 

[CeeB1]

Your additional query requires an additional procedure.
Fyi, my previously posted code is not limited to one worksheet, but affects all worksheets in the same workbook that contain one or more hyperlinks.
Note that the new procedure is dependent on some separate functions as well.
For completeness I will post all relevant code.

Public Sub CeeB1()
   
    ' == USAGE EXAMPLES ==
    '                      workbook,    old    ,    new
   'RelinkAllHyperlinks ThisWorkbook, "ACT 2022", "BUD 2022"
   'RelinkAllHyperlinks ActiveWorkbook, "ACT 2022", "BUD 2022"
  
    '                          ----------- range ------------- ,    old    ,    new
   'RelinkSelectedHyperlinks Sheets("Sheet1").Range("A1:BC200"), "ACT 2022", "BUD 2022"
  
    RelinkSelectedHyperlinks Selection, "ACT 2022", "BUD 2022"

End Sub


Public Sub RelinkAllHyperlinks(ByVal argWb As Workbook, ByVal argOldRefName As String, ByVal argNewRefName As String)
    Dim Sht As Worksheet, Hl As Hyperlink
    For Each Sht In argWb.Worksheets
        For Each Hl In Sht.Hyperlinks
            ApplyRelink Hl, argOldRefName, argNewRefName
        Next Hl
    Next Sht
End Sub

Public Sub RelinkSelectedHyperlinks(ByVal argRng As Range, ByVal argOldRefName As String, ByVal argNewRefName As String)
    Dim Sht As Worksheet, Hl As Hyperlink, Anchor As Range
    Set Sht = argRng.Parent
    For Each Hl In Sht.Hyperlinks
        On Error Resume Next
        Set Anchor = Hl.Range
        On Error GoTo 0
        If Not Anchor Is Nothing Then
            If Not Application.Intersect(argRng, Anchor) Is Nothing Then
                ApplyRelink Hl, argOldRefName, argNewRefName
            End If
        End If
    Next Hl
End Sub

Public Sub ApplyRelink(ByRef argHl As Hyperlink, ByVal argOldRefName As String, ByVal argNewRefName As String)
    If VBA.InStr(1, argHl.SubAddress, ShtNameFromRef(argOldRefName), vbTextCompare) > 0 Then
        If WorksheetExists(argHl.Parent.Parent.Parent, ShtNameFromRef(argNewRefName)) Then
            argHl.SubAddress = VBA.Replace(argHl.SubAddress, BuildRef(argOldRefName), BuildRef(argNewRefName), , , vbTextCompare)
        End If
    End If
End Sub

Public Function ShtNameFromRef(ByVal argRefName As String) As String
    ShtNameFromRef = VBA.Split(VBA.Replace(argRefName, "'", ""), "!")(0)
End Function

Public Function BuildRef(ByVal argRefName As String) As String
    argRefName = VBA.Replace(argRefName, "'", "")
    BuildRef = VBA.IIf(VBA.InStr(1, argRefName, " ") > 0, "'" & VBA.Replace(argRefName, "!", "'!"), argRefName)
End Function

Public Function WorksheetExists(ByVal argWb As Workbook, ByVal argShtName As String) As Boolean
    On Error Resume Next
    WorksheetExists = Not argWb.Worksheets(argShtName) Is Nothing
End Function

You are an absolute star GWteB- thank you so very very much it is working like a charm. It is going to save me hours and double checking for finger problems.

 

[GWteB]

You're welcome and thanks for letting me know