Option 1: In sheet UDF
You could use the following code by Igor (modified slightly) in a standard module as a worksheet based way of updating Urls via a user defined function (UDF) GetUrl, wrapped inside a HYPERLINK function, to ensure you have a clickable link.
UDF code in standard module:
Option Explicit
Function GetURL(cell As Range, Optional default_value As Variant) as hyperlink
'Lists the Hyperlink Address for a Given Cell
'If cell does not contain a hyperlink, return default_value
If (cell.Hyperlinks.Count <> 1) Then
GetURL = default_value
Else
GetURL = cell.Hyperlinks(1).Address
End If
End Function
Where you deploy by having in a cell in sheet 2, for example, the following
=HYPERLINK(GetURL(Sheet1!A1))
And sheet one cell A1 has the hyperlink being updated.
You would need to tie a refresh of the UDF(calculation) to an event to ensure the hyperlink text visibly updates.
For example, in the sheet containing the UDF you could have the following by Greg Glynn to force a recalculation. Sure you can play around finding an efficient way to do this.
Private Sub Worksheet_Activate()
Cells.Replace What:="=", Replacement:="=", LookAt:=xlPart, SearchOrder _
:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
End Sub
As discussed for the above code:
Cell A1 has the hyperlink being updated
Cell A3 (which could be a cell in a different sheet) has the function GetURL ,wrapped inside the HYPERLINK function, which points at A1.
The function code would go in a standard module:
Press Alt + F11 to open the VBE and then in the project explorer window, right click Insert Module then enter the code into the module that appears e.g.
The trigger code (so the hyperlink text updates) would go in the worksheet code window for each sheet containing the function e.g. if sheet 4 had the GetUrl function in, you would enter in the sheet code window as follows:
As i said in comments, this could be put into a function called when each sheet is activated.
Option 2: Button in worksheet associated with macro which prompts user to select a range containing the old urls and new urls
Or, the following, which is not optimised but i am happy to update as others chip in comments. This would simply be a procedure you place in a standard module you attach to a button (Google assign macro to button in Excel - you would also need to add the Developer tab to the Ribbon)
Option Explicit
Public Sub ReplaceLinks()
Dim linksArr()
Application.ScreenUpdating = False
Dim myRange As Range
Set myRange = Application.InputBox("Please select both columns containing range of hyperlinks to update", Type:=8)
If Not myRange Is Nothing And myRange.Columns.Count = 2 Then
linksArr = myRange.Value
Else
MsgBox "Please select a range of two columns"
Exit Sub
End If
ReDim Preserve linksArr(1 To UBound(linksArr), 1 To 3)
linksArr = ValidateUrls(linksArr)
Dim currentLink As Long
For currentLink = LBound(linksArr, 1) To UBound(linksArr, 1)
If linksArr(currentLink, 3) Then
UpdateMyHyperlink CStr(linksArr(currentLink, 1)), CStr(linksArr(currentLink, 2))
End If
Next currentLink
WriteValidationResults linksArr, myRange
End Sub
Private Function ValidateUrls(ByVal linksArr As Variant) As Variant
Dim currentLink As Long
For currentLink = LBound(linksArr, 1) To UBound(linksArr, 1)
linksArr(currentLink, 3) = IsURLGood(CStr(linksArr(currentLink, 1)))
Next currentLink
ValidateUrls = linksArr
End Function
Public Function IsURLGood(ByVal url As String) As Boolean
'https://www.experts-exchange.com/questions/27240517/vba-check-URL-if-it-is-active-or-not.html by m4trix
Dim request As WinHttpRequest
Set request = New WinHttpRequest
On Error GoTo IsURLGoodError
request.Open "HEAD", url
request.Send
IsURLGood = request.Status = 200
Exit Function
IsURLGoodError:
IsURLGood = False
End Function
Private Sub UpdateMyHyperlink(ByVal oldUrl As String, ByVal newUrl As String)
Dim ws As Variant
Dim hyperlink As Variant
For Each ws In ThisWorkbook.Worksheets
For Each hyperlink In ws.Hyperlinks
If hyperlink.Address = oldUrl & "/" Then
hyperlink.Address = Application.WorksheetFunction.Substitute(hyperlink.Address, oldUrl, newUrl)
hyperlink.TextToDisplay = newUrl
End If
Next
Next
End Sub
Private Sub WriteValidationResults(ByVal linksArr As Variant, ByRef myRange As Range)
Dim isUrlValidOutput As Range
Set isUrlValidOutput = myRange.Offset(, 2).Resize(myRange.Rows.Count, 1)
isUrlValidOutput = Application.Index(linksArr, , 3)
isUrlValidOutput.Offset(-1, 0).Resize(1) = "Valid URL"
End Sub
And you would set your data up as follows (column D is added via the code):
Adding a forms control button:
Automatically it will pop up a window where you can then assign the update links procedure:
