Изменился путь для гиперссылки в excel

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

Sub Replace_Hyperlink_inShape()
    Dim oSh As Shape, sWhatRep As String, sRep As String
    Dim s As String
 
    sWhatRep = InputBox("Что меняем?", "Ввод данных", "www.excel-vba.com")
    sRep = InputBox("На что меняем?", "Ввод данных", "www.excel-vba.ru")
 
    On Error Resume Next
    For Each oSh In ActiveSheet.Shapes
        s = ""
        s = oSh.Hyperlink.Address
        If s <> "" Then
            oSh.Hyperlink.Address = Replace(oSh.Hyperlink.Address, sWhatRep, sRep)
        End If
    Next
End Sub

Гиперссылки всех объектов на листе будут изменены. Если у объекта нет гиперссылки — объект будет пропущен.

 
Чтобы

заменить гиперссылки только в выделенных объектах

необходимо строку

For Each oSh In ActiveSheet.Shapes

заменить на такую:

For Each oSh In Selection.ShapeRange

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

• Remove From My Forums

• Общие обсуждения

• Здравствуйте.

  Имеется Microsoft Office 2010 Standart. При работе в Excel по неустановленным причинам на нескольких компьютерах сети в различных файлах произвольным образом изменяется путь гиперрсылки с \srv.domain.localshare1.pdf на C:UsersuserAppDataRoamingMicrosoftExcelshare1.pdf.

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

  Прошу помощи в решении проблемы.

  Спасибо

  • Изменен тип

    17 мая 2013 г. 13:28

Excel для Microsoft 365 Word для Microsoft 365 Excel 2019 Word 2019 Excel 2016 Word 2016 Excel 2013 Word 2013 Excel 2010 Word 2010 Еще…Меньше

Нужна дополнительная помощь?

• Remove From My Forums

• Question

• All the Excel network links created in 2007/2003 change c:… when open up in Excel 2010. It is impossible to update them all manually as we have 10000+ files each contains
  10000000000 links +.

   The file and links work ok from a Windows XP machine with Excel 2007.

   For example:

   G:FinanceFinance Drive — RestructuredReportingFY10 is replaced by C:UsersnsapalaAppDataRoamingMicrosoftExcelXLSTART

  We have changed the startup location but it didn’t seem to fix the issue.

  Help Please!!!..Questions or ideas very much welcome.

  • Edited by

    Thursday, August 26, 2010 7:31 PM