VBA to list all links (external links AND hyperlinks) together with the cells containing the links

[accountant606]

Hello,

I need to use VBA to list all links (both external links AND hyperlinks) in a workbook and have the location of the corresponding cells that contain these links listed beside them for reference. I do have the code (see Table 1: Code at the bottom of this post) to pull the cell reference for external links from this thread here:

VBA to list all external links together with the cells containing the links

However, the VBA does not also find hyperlinks. I need it to go one more step further to also give me the location of hyperlinks as well.

Here is an example sheet where I want to extract all links (not just external links but also hyperlinks)

Book1 (version 1).xlsm
	A	B	C
1
2		5
3		Link to youtube
4
5
6
7
Sheet1

Cell Formulas
Range	Formula
B2	B2	='[Book2-External Link.xlsx]Sheet1'!$B$2

However, when I run the macro in 'Table 1: Code', I only get this output

Book1 (version 1).xlsm
	A	B	C
1	Location	Reference
2	[Book1 (version 1).xlsm]Sheet1'!$B$2	='[Book2-External Link.xlsx]Sheet1'!$B$2
3
4
5
6
7
Sheet2

In other words, this macro is not also detecting the hyperlink to youtube in cell B3 of 'Sheet 1'. Can you help me improve this macro to also detect hyperlinks?

Your help is greatly appreciated.
Jay


Table 1: Code
Option Explicit

Sub ListLinks()

Dim Wks As Worksheet
Dim rFormulas As Range
Dim rCell As Range
Dim aLinks() As String
Dim Cnt As Long

If ActiveWorkbook Is Nothing Then Exit Sub

Cnt = 0
For Each Wks In Worksheets
On Error Resume Next
Set rFormulas = Wks.UsedRange.SpecialCells(xlCellTypeFormulas)
On Error GoTo 0
If Not rFormulas Is Nothing Then
For Each rCell In rFormulas
If InStr(1, rCell.Formula, "[") > 0 Then
Cnt = Cnt + 1
ReDim Preserve aLinks(1 To 2, 1 To Cnt)
aLinks(1, Cnt) = rCell.Address(, , , True)
aLinks(2, Cnt) = "'" & rCell.Formula
End If
Next rCell
End If
Next Wks

If Cnt > 0 Then
Worksheets.Add before:=Worksheets(1)
Range("A1").Resize(, 2).Value = Array("Location", "Reference")
Range("A2").Resize(UBound(aLinks, 2), UBound(aLinks, 1)).Value = Application.Transpose(aLinks)
Columns("A:B").AutoFit
Else
MsgBox "No links were found within the active workbook.", vbInformation
End If

End Sub

 

[John_w]

Try this modified macro.

The original macro only lists links to external workbooks. This new macro also lists hyperlinks to external web pages, hyperlinks created using Insert -> Link and hyperlinks created using simple =HYPERLINK( function formulas.

Sub ListLinks()

    Dim Wks As Worksheet
    Dim rFormulas As Range
    Dim rCell As Range
    Dim aLinks() As String
    Dim Cnt As Long
    Dim p1 As Long, p2 As Long
    Dim linkDestination As String
    Dim link As Hyperlink
    
    If ActiveWorkbook Is Nothing Then Exit Sub
    
    Cnt = 0
    For Each Wks In Worksheets
        On Error Resume Next
        Set rFormulas = Wks.UsedRange.SpecialCells(xlCellTypeFormulas)
        On Error GoTo 0
        If Not rFormulas Is Nothing Then
            For Each rCell In rFormulas
                If InStr(1, rCell.Formula, "[") > 0 Then
                    Cnt = Cnt + 1
                    ReDim Preserve aLinks(1 To 2, 1 To Cnt)
                    aLinks(1, Cnt) = rCell.Address(, , , True)
                    aLinks(2, Cnt) = "'" & rCell.Formula
                Else
                    p1 = InStr(1, rCell.Formula, "=HYPERLINK(", vbTextCompare)
                    If p1 = 1 Then
                        p1 = p1 + Len("=HYPERLINK(")
                        p2 = InStr(p1 + 1, rCell.Formula, Chr(34))
                        linkDestination = Mid(rCell.Formula, p1 + 2, p2 - p1 - 2)
                        Cnt = Cnt + 1
                        ReDim Preserve aLinks(1 To 2, 1 To Cnt)
                        aLinks(1, Cnt) = rCell.Address(, , , True)
                        aLinks(2, Cnt) = "'" & linkDestination
                    End If
                End If
            Next rCell
        End If
        For Each link In Wks.Hyperlinks
            Cnt = Cnt + 1
            ReDim Preserve aLinks(1 To 2, 1 To Cnt)
            aLinks(1, Cnt) = link.Range.Address(, , , True)
            If link.Address = "" Then
                aLinks(2, Cnt) = "'" & link.SubAddress
            Else
                aLinks(2, Cnt) = "'" & link.Address
            End If
        Next
    Next Wks
    
    If Cnt > 0 Then
        Worksheets.Add before:=Worksheets(1)
        Range("A1").Resize(, 2).Value = Array("Location", "Reference")
        Range("A2").Resize(UBound(aLinks, 2), UBound(aLinks, 1)).Value = Application.Transpose(aLinks)
        Columns("A:B").AutoFit
    Else
        MsgBox "No links were found within the active workbook.", vbInformation
    End If

End Sub

Please post VBA code between [CODE=vba]VBA code here[/CODE] tags.

 

[accountant606]

Try this modified macro.

The original macro only lists links to external workbooks. This new macro also lists hyperlinks to external web pages, hyperlinks created using Insert -> Link and hyperlinks created using simple =HYPERLINK( function formulas.

Sub ListLinks()

    Dim Wks As Worksheet
    Dim rFormulas As Range
    Dim rCell As Range
    Dim aLinks() As String
    Dim Cnt As Long
    Dim p1 As Long, p2 As Long
    Dim linkDestination As String
    Dim link As Hyperlink
   
    If ActiveWorkbook Is Nothing Then Exit Sub
   
    Cnt = 0
    For Each Wks In Worksheets
        On Error Resume Next
        Set rFormulas = Wks.UsedRange.SpecialCells(xlCellTypeFormulas)
        On Error GoTo 0
        If Not rFormulas Is Nothing Then
            For Each rCell In rFormulas
                If InStr(1, rCell.Formula, "[") > 0 Then
                    Cnt = Cnt + 1
                    ReDim Preserve aLinks(1 To 2, 1 To Cnt)
                    aLinks(1, Cnt) = rCell.Address(, , , True)
                    aLinks(2, Cnt) = "'" & rCell.Formula
                Else
                    p1 = InStr(1, rCell.Formula, "=HYPERLINK(", vbTextCompare)
                    If p1 = 1 Then
                        p1 = p1 + Len("=HYPERLINK(")
                        p2 = InStr(p1 + 1, rCell.Formula, Chr(34))
                        linkDestination = Mid(rCell.Formula, p1 + 2, p2 - p1 - 2)
                        Cnt = Cnt + 1
                        ReDim Preserve aLinks(1 To 2, 1 To Cnt)
                        aLinks(1, Cnt) = rCell.Address(, , , True)
                        aLinks(2, Cnt) = "'" & linkDestination
                    End If
                End If
            Next rCell
        End If
        For Each link In Wks.Hyperlinks
            Cnt = Cnt + 1
            ReDim Preserve aLinks(1 To 2, 1 To Cnt)
            aLinks(1, Cnt) = link.Range.Address(, , , True)
            If link.Address = "" Then
                aLinks(2, Cnt) = "'" & link.SubAddress
            Else
                aLinks(2, Cnt) = "'" & link.Address
            End If
        Next
    Next Wks
   
    If Cnt > 0 Then
        Worksheets.Add before:=Worksheets(1)
        Range("A1").Resize(, 2).Value = Array("Location", "Reference")
        Range("A2").Resize(UBound(aLinks, 2), UBound(aLinks, 1)).Value = Application.Transpose(aLinks)
        Columns("A:B").AutoFit
    Else
        MsgBox "No links were found within the active workbook.", vbInformation
    End If

End Sub

Please post VBA code between [CODE=vba]VBA code here[/CODE] tags.

John,

This worked like a charm. Thank you kindly!