Макрос для исправления повреждённых гиперссылок во всей книге Excel

Макрос для исправление повреждённых гиперссылок во всей книге:

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

Комментарии

Настройки просмотра комментариев

Выберите нужный метод показа комментариев и нажмите "Сохранить установки".

Может быть ты раньше сохранял в формате 2007-2010 экселя (xlsx), а нынче в старый формат (xls)?

Да, действительно, в директорию Q:\Тендерный отдел\01_Процедуры\ и все сразу заработало!!!
От души благодарю!!! Единственное, почему файл весит в два раза больше теперь!!!?

Ну а название макроса зачем удалили?

Замените

Sub ()

на
Sub test()

и всё будет работать

Вот смотри, мой макрос тоже тот же но немного переделанный.

Sub ZamenaIsporchennihGiperssilok()
    On Error Resume Next
    Dim hl As Hyperlink, oldString As String, newString As String, sh As Worksheet
    ' part of hyperlink, which you want to change
    oldString = "C:\Users\fss\AppData\Roaming\Microsoft\Excel\"
    ' to what to change
    newString = "Q:\Тендерный отдел\01_Процедуры\"
    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, скопируй нужный эксель файл в директорию Q:\Тендерный отдел\01_Процедуры\, затем запусти этот файл экселя оттуда, выполни этот скрипт, затем пересохрани (сохранить как...) в нужное место.

Sub ZamenaIsporchennihGiperssilok()
    On Error Resume Next
    Dim hl As Hyperlink, oldString As String, newString As String, sh As Worksheet
    ' part of hyperlink, which you want to change
    oldString = "C:\Users\fss\AppData\Roaming\Microsoft\Excel\"
    ' to what to change
    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

У тебя появилась данная проблема потому, что у тебя завис эксель, ты закрыл, эксель перезапустился, ты открыл автосохранение, чтобы не потерять работу, но при этом потерялись ссылки. Потому что ссылки были относительные.

Отпишешься.

Начну с начала.
Были Гиперссылки правильные стали не правильные.
По Гуглил, нашел макрос, все сделал как следует, но в результате - ругается.
Ват сам макрос:

Sub ()
   On Error Resume Next
   Dim hl As Hyperlink, oldString As String, newString As String, sh As Worksheet
   oldString = "C:\Users\fss\AppData\Roaming\Microsoft\Excel\"
   newString = "Q:\Тендерный отдел\01_Процедуры\"
    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 

что тебе конкретно надо? напиши свои потребности я отвечу. с тем материалом я давно разобрался так что думаю смогу тебе помочь.

Очень сильно обрадовался когда нашел данный материал. Спасибо!
Все сделал как написано, и .... результат: выскакивает окошко с текстом "compile error: expected: identifier"
Что делать, подскажите пожалуйста!!!

то есть ячейки сначала были пустые, затем я добавил сюда автозаполнением с первых двух гиперссылочных до 99, то меняются только первые 2 ячейки, которые я вбивал руками.

Скажите, а как мне создать ссылки, а затем их пронумеровать? то есть так:
а01.рсш
а02.рсш
...
а99.рсш

Потому что при этом раскладе у меня не конвертит:
Sub ZamenaIsporchennihGiperssilok()
On Error Resume Next
Dim hl As Hyperlink, oldString As String, newString As String, sh As Worksheet
' part of hyperlink, which you want to change
oldString = "rrr"
' to what to change
newString = "PIR 00"
i = 36
For Each sh In ActiveWorkbook.Worksheets ' ?????????? ??? ????? ? ???????? ?????
For Each hl In sh.Hyperlinks ' ?????????? ??? ??????????? ?? ?????
If hl.Address Like "*" & oldString & "*" Then
i = i + 1
st = newString + CStr(i)
hl.Address = Replace(hl.Address, oldString, st)
End If
Next
Next sh
End Sub

Спасибо, это как раз то, что мне было нужно.

Отправить комментарий

Содержание этого поля является приватным и не предназначено к показу.
CAPTCHA
Подтвердите, пожалуйста, что вы - человек:
              ___          ____    _   _   _ 
__ __ / _ \ ___ | __ ) | | | | | |
\ \ /\ / / | (_) | / __| | _ \ | |_| | | |
\ V V / \__, | \__ \ | |_) | | _ | | |
\_/\_/ /_/ |___/ |____/ |_| |_| |_|
Введите код, изображенный в стиле ASCII-арт.

Не получается применить макрос? Не удаётся изменить код под свои нужды?

Оформите заказ у нас на сайте, не забыв прикрепить примеры файлов, и описать, что и как должно работать.