Sub HyperlinkAdressChange()
' source
http://www.ms-office-forum.net/forum/showthread.php?t=286276
' 2014-01-30 Stefan Baunack:
' Change analyse all hyperlinks in Workbook, Keyword: Roaming
' Input new string
Dim hl As Hyperlink
Dim ws As Worksheet
Dim nNumFound As Long
Dim sWSName, sRoamingString, sNewString, sMessage, sTitle As String
sRoamingString = "AppData\Roaming\Microsoft\Excel"
sNewString = "Documents\Buero"
sTitle = "Enter new string for hyperlinks" ' Set title
sMessage = "Hyperlinks containing >Roaming< found." & vbCrLf & "Please enter new string for" & vbCrLf & sRoamingString ' Set prompt.
For Each ws In ActiveWorkbook.Worksheets ' test: Roaming
nNumFound = 0
For Each hl In ws.Hyperlinks
If InStr(hl.Address, "Roaming") > 0 Then nNumFound = nNumFound + 1
Next
If nNumFound = 0 Then
MsgBox "No link containing >Roaming< found.", vbOKOnly, "Worksheet >" & sWSName & "< checked"
Exit Sub
Else
sNewString = InputBox(sMessage, sTitle)
If Len(sNewString) = 0 Then Exit Sub
End If
Next
For Each ws In ActiveWorkbook.Worksheets
nNumFound = 0
sWSName = ws.Name
For Each hl In ws.Hyperlinks
If InStr(hl.Address, "Roaming") > 0 Then
nNumFound = nNumFound + 1
hl.Address = Replace(hl.Address, sNewString, sRoamingString)
' Change text to diaplay also
hl.TextToDisplay = Replace(hl.TextToDisplay, sNewString, sRoamingString)
End If
Next
If nNumFound = 0 Then
MsgBox "No link containing >Roaming< found.", vbOKOnly, "Worksheet >" & sWSName & "< checked"
Else
MsgBox nNumFound & "Link containing >Roaming< found.", vbOKOnly, "Worksheet >" & sWSName & "< checked"
End If
Next
End Sub