В этой статье я хочу рассказать как можно быстро и качественно изменить адреса гиперссылок на листе 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)
        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)
        End If
    Next rCell
    Application.ScreenUpdating = 1
End Sub

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

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