Макрос для исправления повреждённых гиперссылок во всей книге 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

72830 просмотров

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

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

Гость, 20 Апр 2012 - 13:26.#1

как сделать чтобы менял обычные ссылки а не гипер ?

Гость, 13 Апр 2012 - 15:18.#2

Вроде бы формат файла не изменился (xls) 97-2003, как был так и остался (не у всех, просматривающих, таблицу есть новый (xlsx))

Шамиль, 13 Апр 2012 - 15:05.#3

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

Гость, 13 Апр 2012 - 14:55.#4

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

Игорь (администратор сайта), 13 Апр 2012 - 14:28.#5

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

Замените

Sub ()

на

Sub test()

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

Шамиль, 13 Апр 2012 - 14:26.#6

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

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

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

Отпишешься.

Гость, 13 Апр 2012 - 14:18.#7

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

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

Шамиль, 13 Апр 2012 - 14:12.#8

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

Гость, 13 Апр 2012 - 14:02.#9

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

Шамиль, 9 Дек 2011 - 16:38.#10

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

Шамиль, 9 Дек 2011 - 16:36.#11

Скажите, а как мне создать ссылки, а затем их пронумеровать? то есть так:
а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

Шамиль, 9 Дек 2011 - 15:30.#12

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

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

Комментарии

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

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

НАДСТРОЙКИ ДЛЯ EXCEL