用於修復Excel中損壞的超鏈接的腳本

我有一個用於跟蹤工作訂單的電子表格。表格的第一列有數字，從14-0001開始，然後一直按順序繼續。這些號碼被超鏈接到他們各自工單的.XLS（例如包含14-0001個鏈接到Z：\ WorkOrders \ 14-0001-任務名稱\ 14-0001-任務名稱.xls的單元格）用於修復Excel中損壞的超鏈接的腳本

問題是，我的電腦死機了，當Excel恢復的文件中的所有超鏈接變更情況：從

**"Z:\blah blah\WorkOrders\14-****-Task Name\14-****-Task Name.xls"**

到

**"C:\Users\blahblah\WorkOrders\14-****-Task Name\14-****-Task Name.xls"**

有數百個條目，所以我希望我可以運行一個腳本來解決所有的的超鏈接。

繼承人的腳本，我發現，從我的理解是應該做我想做的上網，但是當我從VB窗口在Excel中運行該腳本，我得到「編譯錯誤：參數不可選」，它凸顯Sub CandCHyperlinx()

代碼：

Option Explicit 
Sub CandCHyperlinx() 

Dim cel As Range 
Dim rng As Range 
Dim adr As String 
Dim delstring As String 

'string to delete: CHANGE ME! (KEEP quotes!) 
delstring = "C:\Users\***\AppData\Roaming\Microsoft\Excel\" 

'get all cells as range 
Set rng = ActiveSheet.UsedRange 

'ignore non hyperlinked cells 
On Error Resume Next 

'check every cell 
For Each cel In rng 
    'skip blank cells 
    If cel <> "" Then 
     'attempt to get hyperlink address 
     adr = cel.Hyperlinks(1).Address 
     'not blank? then correct it, is blank get next 
     If adr <> "" Then 
      'delete string from address 
      adr = Application.WorksheetFunction.Substitute(adr, delstring) 
      'put new address 
      cel.Hyperlinks(1).Address = adr 
      'reset for next pass 
      adr = "" 
     End If 
    End If 
Next cel 

End Sub

這甚至合適的劇本？我究竟做錯了什麼？

來源

2014-12-02 Matt

'替代'是什麼突出與錯誤，這是因爲它需要三個參數不是兩個。 [查看此鏈接]（http://msdn.microsoft.com/en-us/library/office/ff194878%28v=office.15%29.aspx）以獲取更多信息。試試這個：'adr = Application.WorksheetFunction.Substitute（adr，delstring，「C：\ Users \」）' – 2014-12-02 20:23:03

你可以不應用Find/Replace嗎？ – pnuts 2014-12-02 21:03:53

@pnuts我以爲也是'Find'在超鏈接地址上不起作用，或者我應該說，它在VBA之外不起作用。 – 2014-12-02 21:20:20

試試這個：

Sub Macro1() 

    Const FIND_TXT As String = "C:\" 'etc 
    Const NEW_TXT As String = "Z:\" 'etc 

    Dim rng As Range, hl As Hyperlink 

    For Each rng In ActiveSheet.UsedRange.Cells 

     If rng.Hyperlinks.Count > 0 Then 
      Set hl = rng.Hyperlinks(1) 
      Debug.Print rng.Address(), "Before", hl.TextToDisplay, hl.Address 
      hl.TextToDisplay = Replace(hl.TextToDisplay, FIND_TXT, NEW_TXT) 
      hl.Address = Replace(hl.Address, FIND_TXT, NEW_TXT) 
      Debug.Print rng.Address(), "After", hl.TextToDisplay, hl.Address 
     End If 

    Next rng 


End Sub

來源

2014-12-03 00:59:45

我試過了，仍然沒有結果。當我點擊運行窗口閃爍一秒鐘，然後什麼也沒有。沒有錯誤，沒有固定的HL。有沒有辦法查看某種類型的日誌，以顯示單擊「運行」時發生的情況？ – Matt 2014-12-04 18:58:32

檢查VB編輯器中的「立即」窗格 - 如果找到任何超鏈接，應該有輸出。 – 2014-12-04 19:05:16

好吧，在即時窗格中，它會列出AFTER 14-0040之後的所有超鏈接。這意味着它沒有找到的前40個HL。這就是每個記錄的輸出結果： '$ B $ 49之前14-0046 ../AppData/Roaming/Microsoft/Excel/Work-Orders/Completed/14-0046-WO-LN7-550 Luxfer Tank Fitting/14-0046-WO-LN7-550 Luxfer Tank Fitting-Completed.pdf' '$ B $ 49 After 14-0046 ../AppData/Roaming/Microsoft/Excel/Work-Orders/Completed/14-0046- WO-LN7-550 Luxfer油箱配件/ 14-0046-WO-LN7-550 Luxfer油箱配件 - 完成.pdf' – Matt 2014-12-04 23:54:02

我剛剛有同樣的問題，而我嘗試了宏並沒有爲我工作。這個改編自蒂姆的上面，並從這個線程Office Techcentre thread。在我的情況下，我所有的超鏈接都在B列，在第3行和第400行之間，並且隱藏在文件名後面，我想將鏈接放回到我所屬的Dropbox文件夾中。

Sub FixLinks3() 

Dim intStart As Integer 

Dim intEnd As Integer 

Dim strCol As String 

Dim hLink As Hyperlink 

intStart = 2 

intEnd = 400 

strCol = "B" 


For i = intStart To intEnd 

    For Each hLink In ActiveSheet.Hyperlinks 
    hLink.TextToDisplay = Replace (hLink.TextToDisplay, "AppData/Roaming/Microsoft/Excel", 
    "Dropbox/References") 
    hLink.Address = Replace(hLink.Address, "AppData/Roaming/Microsoft/Excel", 
    "Dropbox/References") 
    Next hLink 

    Next i 

End Sub

感謝您的幫助，Tim！

來源

2016-01-07 14:37:52 confused76

用於修復Excel中損壞的超鏈接的腳本

回答

相關問題