Макрос для исправление повреждённых гиперссылок во всей книге:
Sub ЗаменаИспорченныхГиперссылок()
On Error Resume Next
Dim hl As Hyperlink, oldString As String, newString As String, sh As Worksheet
' часть гиперссылки, подлежащая замене
oldString = "C:\Documents and settings\Бухгалтер\Application data"
' на что заменяем
newString = "\\адрес_сервера"
For Each sh In ActiveWorkbook.Worksheets ' перебираем все листы в активной книге
For Each hl In sh.Hyperlinks ' перебираем все гиперссылки на листе
If hl.Address Like oldString & "*" Then
hl.Address = Replace(hl.Address, oldString, newString)
End If
Next
Next sh
End Sub Макрос может быть полезен для замены абсолютных гиперссылок на относительные, а также помогает вернуть работоспособность ссылок после случайного сохранения файла Excel в другой папке (на другом диске).
Если нужно заменить несколько вариантов неверных ссылок, код будет таким:
Sub ЗаменаИспорченныхГиперссылок_2()
On Error Resume Next
Dim hl As Hyperlink, newString$, sh As Worksheet
' часть гиперссылки, подлежащая замене
oldString1 = "C:\Documents and settings\Бухгалтер\1"
oldString2 = "C:\Documents and settings\Бухгалтер\2"
' на что заменяем
newString = "\\адрес_сервера"
For Each sh In ActiveWorkbook.Worksheets ' перебираем все листы в активной книге
For Each hl In sh.Hyperlinks ' перебираем все гиперссылки на листе
If hl.Address Like oldString1 & "*" Then hl.Address = Replace(hl.Address, oldString1, newString)
If hl.Address Like oldString2 & "*" Then hl.Address = Replace(hl.Address, oldString2, newString)
Next
Next sh
End SubРасширенная версия этого макроса учитывает, что слеш в ссылках может быть как прямым, так и обратным, а также выводит информацию о количестве произведённых замен, и список ссылок из файла, которые не были обработаны (к которым замены не были применены)
Sub ЗаменаИспорченныхГиперссылок2()
On Error Resume Next
Dim hl As Hyperlink, oldString$, newString$, sh As Worksheet, n&, msg$, coll As New Collection, Item
' часть гиперссылки, подлежащая замене
oldString = "../../AppData/Roaming/Microsoft/Excel/"
' на что заменяем
newString = "C:\Users\Admin\Desktop\ОТЧЁТЫ ВСЕ\"
For Each sh In ActiveWorkbook.Worksheets ' перебираем все листы в активной книге
For Each hl In sh.Hyperlinks ' перебираем все гиперссылки на листе
' Debug.Print hl.Address
If (hl.Address Like oldString & "*") Or (hl.Address Like Replace(oldString, "/", "\") & "*") Then
hl.Address = Replace(hl.Address, oldString, newString, , , vbTextCompare)
hl.Address = Replace(hl.Address, Replace(oldString, "/", "\"), newString, , , vbTextCompare)
n = n + 1
Else
If InStr(1, hl.Address, "mailto", vbTextCompare) = 0 Then coll.Add hl.Address, UCase(hl.Address)
End If
Next
Next sh
For Each Item In coll
msg$ = msg$ & Item & vbNewLine
Next
MsgBox "Заменено гиперссылок: " & n & IIf(Len(msg$), vbNewLine & vbNewLine & _
"Также в файле найдены ссылки на:" & vbNewLine & msg$, ""), vbInformation
End Sub
