Форум по VBA и MS Office

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
          If rCell.Hyperlinks(1).Address <> "" Then
              rCell.Hyperlinks(1).Address = Replace(rCell.Hyperlinks(1).Address, sWhatRep, sRep)
          End If
          If rCell.Hyperlinks(1).SubAddress <> "" Then
              rCell.Hyperlinks(1).SubAddress = Replace(rCell.Hyperlinks(1).SubAddress, sWhatRep, sRep)
          End If
      End If
  Next rCell
  Application.ScreenUpdating = 1
End Sub