List Hyperlinks in Excel - vba

Question

I ahve an Excel work book containing a large number of sheets. Each sheet has between 1 and 12 Hyperlinks to different documents on a website. These dicuments are updated from time to time. I would like a macro that lists all the Hyperlinks in a new sheet but also lists the sheet name next to each link. I have the following that lists the Hyperlinks and the cell ref
Sub CopyHyperLinks()
Dim rCell As Range
Dim ws As Worksheet
Dim Lhyper As Long
On Error Resume Next
Application.DisplayAlerts = False
Sheets("Hypers").Delete
On Error Goto 0
Application.DisplayAlerts = True
Sheets.Add().Name = "Hypers"
For Each ws In Worksheets
If ws.Name <> "Hypers" Then
For Lhyper = 1 To ws.UsedRange.Hyperlinks.Count
ws.Hyperlinks(Lhyper).Range.Copy
With Sheets("Hypers").Cells(Rows.Count, 1).End(x1Up)
.Offset(1, 0).PasteSpecial
.Offset(1, 1) = ws.Hyperlinks(Lhyper).Range.Address
End
Application.CutCopyMode = False
Next Lhyper
End If
Next ws
End Sub
How can i modify this to show the sheet name instead of the cell ref.
is it also possible to then check that these Hyperlinks are valid destinations?

Answer 1

You can get the name of the worksheet of the hyperlink with this line:
ws.Hyperlinks(Lhyper)..Range.Worksheet.Name
Here's is your reworked code (it contained some other syntactical errors that I corrected):
Sub CopyHyperLinks()
Dim rCell As Range
Dim ws As Worksheet
Dim Lhyper As Long
Dim rngLink As Range
Application.DisplayAlerts = False
On Error Resume Next
Sheets("Hypers").Delete
On Error GoTo 0
Application.DisplayAlerts = True
Sheets.Add().Name = "Hypers"
For Each ws In Worksheets
If ws.Name <> "Hypers" Then
For Lhyper = 1 To ws.UsedRange.Hyperlinks.Count
Set rngLink = ws.Hyperlinks(Lhyper).Range
rngLink.Copy
With Sheets("Hypers").Cells(Rows.Count, 1).End(xlUp)
.Offset(1, 0).PasteSpecial
.Offset(1, 1) = rngLink.Address
.Offset(1, 2) = rngLink.Worksheet.Name
.Offset(1, 3) = CheckHyperlink(ws.Hyperlinks(Lhyper).Address)
End With
Application.CutCopyMode = False
Next Lhyper
End If
Next ws
End Sub
If you want to verify the links, include the code from this answer. Include this line in your code:
.Offset(1, 3) = CheckHyperlink(ws.Hyperlinks(Lhyper).Address)
and also this routine:
Public Function CheckHyperlink(ByVal strUrl As String) As Boolean
Dim oHttp As New MSXML2.XMLHTTP30
On Error GoTo ErrorHandler
oHttp.Open "HEAD", strUrl, False
oHttp.send
If Not oHttp.Status = 200 Then CheckHyperlink = False Else CheckHyperlink = True
Exit Function
ErrorHandler:
CheckHyperlink = False
End Function
You need to include a reference to the "Microsoft XML" library in your VBA project.