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