Версия для печати

Как массово изменить гиперссылки?

26071
Написать комментарий К комментариям
Что умеет Excel

 

В этой статье я хочу рассказать как можно быстро и качественно изменить адреса гиперссылок на листе Excel.

Существуют ситуации, когда на листе есть много гиперссылок на различные папки или интернет ресурсы. И вот случилось вдруг так, что адреса надо поменять(либо домен сменился, либо на сервере добавилась директория и эти изменения надо отразить в гиперссылках). Для примера возьмем такие исходные данные: надо заменить текст «.excel_vba» на текст «excel-vba«.
Тут все зависит от того, каким способом установлена гиперссылка. Если установлена через формулу ГИПЕРССЫЛКА, то все просто:

  1. выделяем диапазон с гиперссылками;
  2. жмем Ctrl+H.
    • Найти: .excel_vba
    • Заменить на: excel-vba
    • Жмете кнопочку «Параметры» и устанавливаете Область поискаФормулы и снимаете галочку «Ячейка целиком«.
  3. Жмете «Заменить все«

Теперь адреса ссылок должны поменяться.
Все гораздо хуже, если гиперссылки у Вас созданы через стандартное меню: правый клик мыши на ячейке — Гиперссылка. Тут фокус с заменой через Ctrl+H не пройдет. Но зато можно применить такой код:

Sub Replace_Hyperlink()
    Dim rCell As Range, rRange As Range, sWhatRep As String, sRep As String
    On Error Resume Next
    Set rRange = Application.InputBox("Укажите диапазон для замены", "Выбор данных", Type:=8)
    If rRange Is Nothing Then Exit Sub
    sWhatRep = InputBox("Что меняем?", "Ввод данных", ".excel_vba")
    sRep = InputBox("На что меняем?", "Ввод данных", "excel-vba")
    If sWhatRep = "" Then Exit Sub
    If sRep = "" Then
        If MsgBox("Хотите заменить " & sWhatRep & " на пусто?", vbCritical + vbYesNo, "Предупреждение") = vbNo Then Exit Sub
    End If
    Application.ScreenUpdating = 0
    For Each rCell In rRange
        If rCell.Hyperlinks.Count > 0 Then
            If rCell.Hyperlinks(1).Address = rCell.Value Then
                rCell = Replace(rCell.Value, sWhatRep, sRep)
            End If
            rCell.Hyperlinks(1).Address = Replace(rCell.Hyperlinks(1).Address, sWhatRep, sRep)
            rCell.Hyperlinks(1).SubAddress = Replace(rCell.Hyperlinks(1).SubAddress, sWhatRep, sRep)
        End If
    Next rCell
    Application.ScreenUpdating = 1
End Sub
Sub Replace_Hyperlink()
    Dim rCell As Range, rRange As Range, sWhatRep As String, sRep As String
    On Error Resume Next
    Set rRange = Application.InputBox("Укажите диапазон для замены", "Выбор данных", Type:=8)
    If rRange Is Nothing Then Exit Sub
    sWhatRep = InputBox("Что меняем?", "Ввод данных", ".excel_vba")
    sRep = InputBox("На что меняем?", "Ввод данных", "excel-vba")
    If sWhatRep = "" Then Exit Sub
    If sRep = "" Then
        If MsgBox("Хотите заменить " & sWhatRep & " на пусто?", vbCritical + vbYesNo, "Предупреждение") = vbNo Then Exit Sub
    End If
    Application.ScreenUpdating = 0
    For Each rCell In rRange
        If rCell.Hyperlinks.Count > 0 Then
            If rCell.Hyperlinks(1).Address = rCell.Value Then
                rCell = Replace(rCell.Value, sWhatRep, sRep)
            End If
            rCell.Hyperlinks(1).Address = Replace(rCell.Hyperlinks(1).Address, sWhatRep, sRep)
            rCell.Hyperlinks(1).SubAddress = Replace(rCell.Hyperlinks(1).SubAddress, sWhatRep, sRep)
        End If
    Next rCell
    Application.ScreenUpdating = 1
End Sub

В общем ничего сложного: указываете диапазон с гиперссылками, затем указываете что заменить и в последнюю очередь на что менять.
Данный код необходимо поместить в стандартный модуль, а запустить можно либо нажав Alt+F8, либо прочитать статью Как создать кнопку для вызова макроса на листе? и сделать кнопку.

Скачать пример »

  Tips_Macro_ReplaceHyperlinks.xls (46,0 KiB, 1 302 скачиваний)

Так же см.:
Что такое гиперссылка?



Поддержать автора сайта
  1. GigaPevt_IL
    7 Июль 2011 в 08:12 | #1

    Огромное спасибо автору !

  2. Денис
    23 Август 2011 в 11:36 | #2

    Большой респект автору, ооочень помогло!

  3. Joy
    12 Декабрь 2011 в 19:14 | #3

    Спасибо!
    Очень помогли!

  4. Garisson
    20 Март 2012 в 12:58 | #4

    А как то же самое проделать но только если ссылки на кнопках?

  5. Серёга
    20 Март 2012 в 13:14 | #5

    Сэкономил себе два дня! Автор ваще красава!

  6. 20 Март 2012 в 15:09 | #6

    Garisson — примерно так:

    Sub Replace_Hyperlink()
        Dim rCell As Range, sWhatRep As String, sRep As String
        Dim objShape As Shape, objHyp As Hyperlink
        sWhatRep = InputBox("Что меняем?", "Ввод данных", ".excel_vba")
        sRep = InputBox("На что меняем?", "Ввод данных", "excel-vba")
        If sWhatRep = "" Then Exit Sub
        If sRep = "" Then
            If MsgBox("Хотите заменить " & sWhatRep & " на пусто?", vbCritical + vbYesNo, "Предупреждение") = vbNo Then Exit Sub
        End If
        Application.ScreenUpdating = 0
        On Error Resume Next
        For Each objShape In ActiveSheet.Shapes
            Set objHyp = objShape.Hyperlink
            If Not objHyp Is Nothing Then
                objShape.Hyperlink.Address = Replace(objShape.Hyperlink.Address, sWhatRep, sRep)
                Set objHyp = Nothing
            End If
        Next objShape
        Application.ScreenUpdating = 1
    End Sub
    Sub Replace_Hyperlink()
        Dim rCell As Range, sWhatRep As String, sRep As String
        Dim objShape As Shape, objHyp As Hyperlink
        sWhatRep = InputBox("Что меняем?", "Ввод данных", ".excel_vba")
        sRep = InputBox("На что меняем?", "Ввод данных", "excel-vba")
        If sWhatRep = "" Then Exit Sub
        If sRep = "" Then
            If MsgBox("Хотите заменить " & sWhatRep & " на пусто?", vbCritical + vbYesNo, "Предупреждение") = vbNo Then Exit Sub
        End If
        Application.ScreenUpdating = 0
        On Error Resume Next
        For Each objShape In ActiveSheet.Shapes
            Set objHyp = objShape.Hyperlink
            If Not objHyp Is Nothing Then
                objShape.Hyperlink.Address = Replace(objShape.Hyperlink.Address, sWhatRep, sRep)
                Set objHyp = Nothing
            End If
        Next objShape
        Application.ScreenUpdating = 1
    End Sub
  7. Garisson
    20 Март 2012 в 17:40 | #7

    @Дмитрий(Админ)
    Почему то не срабатывает, в этом месте видимо objShape.Hyperlink.Address = Replace(objShape.Hyperlink.Address, sWhatRep, sRep), вывожу перед этим MsgBox(objShape.Hyperlink.Address) и адреса нет, хотя имена кнопок на листе определяет.

  8. 20 Март 2012 в 21:14 | #8

    Что я могу сказать: я привел примеры. Последний код тоже рабочий — сам проверял. Вам надо лишь адаптировать под себя. Писать код конкретно под Ваши нужны нет времени — вас много, а я один. Обращайтесь в форум.

  9. Garisson
    21 Март 2012 в 08:59 | #9

    Ок спасибо, разберусь.

  10. people
    28 Декабрь 2012 в 18:27 | #10

    Спасибо огромное! Вы меня спасли! Так не хотелось заниматься монотонной работой перед новым годом! С наступающим Вас!

  11. 28 Февраль 2013 в 12:11 | #11

    Огромное спасибо за пост…
    Очень выручили и избавили от массы рутинной работы по восстановлению слетевших ссылок.

  12. Андрей
    13 Апрель 2013 в 21:13 | #12

    Классный макрос! Не думал, что все можно с ним так легко привести в порядок))

  13. Виталий
    5 Сентябрь 2013 в 08:14 | #13

    Отличный макрос.
    Респект.


Комментарии, не имеющие отношения к комментируемой статье, будут удаляться без уведомления и объяснения причин. Если есть вопрос по проблеме в Excel- добро пожаловаться на Форум

Комментарий будет добавлен после проверки администратором.