CODEWITHSUNDEEP
vbaexcelhyperlink
Matt
Matt

Reputation: 3

Script for fixing broken hyperlinks in Excel

I have a spreadsheet that is used for tracking work orders. The first column of the sheet has numbers starting at 14-0001 and continue sequentially all the way down. The numbers were hyperlinked to the .XLS of their respective work order (ex. the cell containing 14-0001 links to Z:\WorkOrders\14-0001-Task Name\14-0001-Task Name.xls)

Problem is, My computer crashed and when Excel recovered the file all the hyperlinks changed from: 

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

to 

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

There are hundreds of entries so I was hoping that I could run a script to fix all of the hyperlinks.

Heres a script I found online which from what I understood is supposed to do what I want, but when I run the script from the VB window in Excel I get "Compile error: Argument not optional" and it highlights Sub CandCHyperlinx()

Code:

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

Is this even the right script? What am I doing wrong?

Upvotes: 0

Views: 2682

Answers (2)

confused76
confused76

Reputation: 21

I've just had the same problem, and all the macros I tried didn't work for me. This one is adapted from Tim's above and from this thread Office Techcentre thread. In my case, all my hyperlinks were in column B, between rows 3 and 400 and 'hidden' behind the filename, and I wanted to put the links back to my Dropbox folder where they belong. 

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

Thanks for your help, Tim!

Upvotes: 0

Tim Williams
Tim Williams

Reputation: 166126

Try this:

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

Upvotes: 1

Related Questions