Заменить (x, y, z) не работает на гиперссылках

Question

У меня есть рабочая книга со многими гиперссылками. Недавно рабочая тетрадь была перенесена в другое место (одна папка «глубже»). Из-за этого все гиперссылки перепутались и теперь:

file:///\\company\common\shared\VRS\Program Files\documents\example.doc

вместо

file:///\\company\common\shared\VRS\documents\example.doc

Я пытаюсь написать макрос для удаления \ Program Files \ part из всех гиперссылок. Нашел несколько примеров в здесь ; здесь ; здесь (переполнение стека) и здесь (еще одно переполнение стека) .

Проблема в том, что ни одно из решений не работает (ничего не изменилось), и у меня нет идей, что я делаю неправильно.

коды, которые я пробовал:

Sub EditHyperlinks()
    Dim lnkH As Hyperlink
    Dim sOld As String
    Dim sNew As String

    sOld = "file:///\\company\common\shared\VRS\Program Files\documents\"
    sNew = "file:///\\company\common\shared\VRS\documents\"

    For Each lnkH In ActiveSheet.Hyperlinks
        lnkH.Address = Replace(lnkH.Address, sOld, sNew)
        lnkH.TextToDisplay = Replace(lnkH.TextToDisplay, sOld, sNew)
    Next
End Sub

---

Sub FixHyperlinks2()
    Dim wks As Worksheet
    Dim hl As Hyperlink
    Dim sOld As String
    Dim sNew As String

    Set wks = ActiveSheet
    sOld = "file:///\\company\common\shared\VRS\Program Files\documents\"
    sNew = "file:///\\company\common\shared\VRS\documents\"
    For Each hl In wks.Hyperlinks
        hl.Address = Replace(hl.Address, sOld, sNew)
    Next hl
End Sub

---

 Sub FindReplaceHLinks(sFind As String, sReplace As String, _
        Optional lStart As Long = 1, Optional lCount As Long = -1)

        Dim rCell As Range
        Dim hl As Hyperlink

        For Each rCell In ActiveSheet.UsedRange.Cells
            If rCell.Hyperlinks.Count > 0 Then
                For Each hl In rCell.Hyperlinks
                    hl.Address = Replace(hl.Address, sFind, sReplace, lStart, lCount, vbTextCompare)
                Next hl
            End If
        Next rCell
    End Sub

    Sub Doit()

        FindReplaceHLinks "file:///\\company\common\shared\VRS\Program Files\documents\", "file:///\\company\common\shared\VRS\documents\"    
    End Sub

---

 Sub test()
        Dim hLink As Hyperlink
        Dim wSheet As Worksheet

        For Each wSheet In Worksheets
           For Each hLink In wSheet.Hyperlinks
                hLink.Address = Replace(hLink.Address, "file:///\\company\common\shared\VRS\Program Files\documents\", "file:///\\company\common\shared\VRS\documents\")
            Next hLink
        Next
    End Sub

Обратите внимание, что я попытался написать адрес (возможно) всех возможных вариантов: начало файла: /// \; \ и без каких-либо \

Может ли кто-нибудь указать мне правильное направление?

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

Answer 1

Что-то вроде этого должно работать, вы хотите разделить текст на \, найти текстовую запись, а затем создать строку обратно.

Function FixFileNames(FileName As String) As String
    Dim i As Long
    Dim testarr As Variant
    Dim fixedString As String

    testarr = Split(FileName, "\", , vbBinaryCompare)

    For i = LBound(testarr) To UBound(testarr)
        If Not testarr(i) = "Program Files" Then fixedString = fixedString & "\" & testarr(i)
    Next

    FixFileNames = Right$(fixedString, Len(fixedString) - 1)
End Function

Sub Tester()
    Debug.Print FixFileNames("file:///\\company\common\shared\VRS\Program Files\documents\example.doc")
End Sub