finding broken links in Excel
The Tip of the Night for May 8, 2015 concerned a macro that will check to see if links on an Excel spreadsheet are active.
The vba code below is an improvement. The code I posted about back in 2015 will generate a new worksheet in your spreadsheet with a list of the filepaths that don't work:
This vba code, posted here by Eawyne, creates a new spreadsheet which lists all of the links, and also indicates which cells the links appear in. [Be sure to use the version posted by Eawyne on 11/18/21 - not the one below it - it will give you incorrect results.]
Refer to column C to see which links do and do not exist. The linked to text appears in column H, and the cell of the original link is indicated in column B.
The code as written by Eawyne will stop after checking 1000 links. It can easily be modified by changing this line:
ReDim arr(1 To 1000, 1 To 9)
Increase the '1000' on this line of code to 9999, or whatever value you need.
It is also set to review links on multiple worksheets - something the older vba code did not do.
Public Sub CollectHyperlinks()
Dim Sht As Worksheet, Hl As Hyperlink, FSO As Object
Dim arr() As Variant, i As Long, Anchor As Object
Dim FileMsg As String, AnchorMsg As String
ReDim arr(1 To 1000, 1 To 9)
Set FSO = CreateObject("Scripting.FileSystemObject")
i = 1
arr(i, 1) = "Worksheet"
arr(i, 2) = "Hyperlink Anchor"
arr(i, 3) = "File"
arr(i, 4) = "Hyperlink Name"
arr(i, 5) = "Hyperlink Address"
arr(i, 6) = "SubAddress"
arr(i, 7) = "ScreenTip"
arr(i, 8) = "TextToDisplay"
arr(i, 9) = "EmailSubject"
For Each Sht In ThisWorkbook.Worksheets
For Each Hl In Sht.Hyperlinks
Set Anchor = Nothing
AnchorMsg = ""
FileMsg = ""
With Hl
If FSO.FileExists(.Address) Then FileMsg = "Exists"
On Error Resume Next
Set Anchor = .Range
If Not Anchor Is Nothing Then
AnchorMsg = Anchor.Address
Else
Set Anchor = .Shape
If Not Anchor Is Nothing Then
AnchorMsg = Anchor.Name
End If
End If
i = i + 1
arr(i, 1) = Sht.Name
arr(i, 2) = AnchorMsg
arr(i, 3) = FileMsg
arr(i, 4) = .Name
arr(i, 5) = .Address
arr(i, 6) = .SubAddress
arr(i, 7) = .ScreenTip
arr(i, 8) = .TextToDisplay
arr(i, 9) = .EmailSubject
On Error GoTo 0
End With
Next Hl
Next Sht
Application.ScreenUpdating = False
With Application.Workbooks.Add.Sheets(1)
.Range("A2").Select
ActiveWindow.FreezePanes = True
With .Rows("1:1")
.Interior.Color = 10837023
.Font.Color = RGB(255, 255, 255)
.Font.Bold = True
End With
.Range("A1").Resize(UBound(arr, 1), UBound(arr, 2)).Value = arr
.Columns("A:I").Columns.AutoFit
End With
Application.ScreenUpdating = True
End Sub