Option Explicit 
 
Private Function GetHyperAddy(Cell As Range) As String 
     'Function purpose:  To return a hyperlink address if one exists
     'Assigns a value of "None" to the string if no hyperlink is present
     
    On Error Resume Next 
    GetHyperAddy = Cell.Hyperlinks.Item(1).Address 
    If Err.Number <> 0 Then GetHyperAddy = "None" 
    On Error GoTo 0 
     
End Function 
 
Sub DistillHyperlinks() 
     'Macro purpose:  To create a list of all Hyperlinks and their
     'addresses contained within a selection of cells
     
    Dim HyperAddy As String, cl As Range, wsTarget As Worksheet, clSource As Range 
     
     'Turn off screen flashing
    Application.ScreenUpdating = False 
     
     'Following required as adding worksheet changes selection
    Set clSource = Selection 
     
     'Check to see if a "Hyperlink List" worksheet exists, and
     'create it if it doesn't
    On Error Resume Next 
    Set wsTarget = Sheets("Hyperlink List") 
    If Err.Number <> 0 Then 
        Set wsTarget = Worksheets.Add 
        With wsTarget 
            .Name = "Hyperlink List" 
            With .Range("A1") 
                .Value = "Location" 
                .ColumnWidth = 20 
                .Font.Bold = True 
            End With 
            With .Range("B1") 
                .Value = "Displayed Text" 
                .ColumnWidth = 25 
                .Font.Bold = True 
            End With 
            With .Range("C1") 
                .Value = "Hyperlink Target" 
                .ColumnWidth = 40 
                .Font.Bold = True 
            End With 
        End With 
        Set wsTarget = Sheets("Hyperlink List") 
    End If 
    On Error GoTo 0 
     
     'Loop through each cell in the user's selection and...
    For Each cl In clSource 
         'Get the hyperlink address
        HyperAddy = GetHyperAddy(cl) 
         
        If Not HyperAddy = "None" Then 
             'If Hyperlink exists, add it to the list on the target sheet
            With wsTarget.Range("A65536").End(xlUp).Offset(1, 0) 
                 'Create hyperlink to cell containing hyperlink
                .Parent.Hyperlinks.Add Anchor:=.Offset(0, 0), _ 
                Address:="", SubAddress:=(cl.Parent.Name) & "!" & (cl.Address) 
                 'List text shown on hyperlink
                .Offset(0, 1).Value = cl.Text 
                 'Create hyperlink to destination
                .Hyperlinks.Add Anchor:=.Offset(0, 2), Address:=HyperAddy 
            End With 
        End If 
    Next cl 
    wsTarget.Select 
End Sub