Replace（x，y，z）在超链接上不起作用

Question

我有很多超链接的工作簿。 最近工作簿已移到另一个位置（一个文件夹“更深”）。 因此，所有超链接都搞砸了，现在是：

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

代替

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

我正在尝试编写宏以从所有超链接中删除\\ Program Files \\部分。 在这里找到一些例子; 在这里 ; 这里（stackoverflow）和这里（另一个stackoverflow） 。

问题是没有一种解决方案有效（什么都没有改变），而且我不知道我在做什么错。

我试过的代码：

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

请注意，我试图写出地址（可能）是所有可能的变体：开始file：/// \\; 没有任何

有人可以指出我正确的方向吗？

PS可能我应该提到文件在本地网络目录中。

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