Option Explicit
'=============================================
'
'  module: mod_DocumentHyperlinks_Excel_CL
'
' LICENSE:
' This code was originally written by Crystal (strive4peace)
' strive4peace2012@yahoo.com
' August 2013
' It is not to be altered or distributed,
' except as part of a NON-COMMERCIAL application.
'
' Licensed under Creative Commons
' License name: Attribution-NonCommercial-ShareAlike 3.0 Unported (CC BY-NC-SA 3.0)
' This license lets you remix, tweak, and build upon your work non-commercially,
' as long as I am credited and you license your new creations under the identical terms.
' You can download and redistribute my work just like the by-nc-nd license,
' and you can also translate, make remixes, and produce new stories based on my work.
' All new work based on my work must carry the same license, so any derivatives will also be non-commercial in nature.
' legal code: http://creativecommons.org/licenses/by-nc-sa/3.0/legalcode
' human-readable summary: http://creativecommons.org/licenses/by-nc-sa/3.0/
' ~ Crystal
' www.AccessMVP.com/strive4peace
' ~ have an awesome day :)
'=============================================

Sub DocumentHyperlinks()
' 130816 Crystal
' Creative Commons license CC BY-NC-SA 3.0

   'Purpose:
   
   'Document hyperlinks in the Active Workbook
   ' to the first sheet in a new workbook (AllHyperlinks)
   
   On Error GoTo Proc_Err
   
   Dim wbSource As Excel.Workbook _
      , shtSource As Excel.Worksheet _
      , shtTarget As Excel.Worksheet _
      , rng As Range

   Dim i As Integer _
       , nRow As Long

   Application.DisplayStatusBar = True
   Set wbSource = ActiveWorkbook

   Workbooks.Add

   Set shtTarget = ActiveWorkbook.ActiveSheet
   ' could have an error if sheet does not exist - may need to uncomment
   '   Sheets.Add

   With shtTarget
      .Name = "AllHyperlinks"
      .Cells(1, 1).Value = "Sheet"
      .Cells(1, 2).Value = "Cell"
      .Cells(1, 3).Value = "TextToDisplay"
      .Cells(1, 4).Value = "Address"
      .Cells(1, 5).Value = "SubAddress"
      .Cells(1, 7).Value = wbSource.Name

      nRow = 2

      For Each shtSource In wbSource.Sheets
         
         'If shtSource.Name = "AllHyperlinks" Then GoTo nextWorksheet

         For Each rng In shtSource.UsedRange
            Application.StatusBar = shtSource.Name & " " & rng.AddressLocal(False, False)

            If rng.Hyperlinks.Count > 0 Then
               shtTarget.Cells(nRow, 1) = shtSource.Name
               shtTarget.Cells(nRow, 2) = rng.Address(False, False)
               shtTarget.Cells(nRow, 3) = rng.Hyperlinks(1).TextToDisplay
               shtTarget.Cells(nRow, 4) = rng.Hyperlinks(1).Address
               shtTarget.Cells(nRow, 5) = rng.Hyperlinks(1).SubAddress
               nRow = nRow + 1
            End If
         Next rng

'nextWorksheet:
      Next shtSource

   End With   'shtTarget
   Call Format_AutoFilter_Freeze(shtTarget, "E")
   
Proc_Exit:
   On Error Resume Next
   Set rng = Nothing
   Set shtSource = Nothing
   Set shtTarget = Nothing
   Set wbSource = Nothing
   
   Exit Sub

Proc_Err:
   MsgBox Err.Description, , _
          "ERROR " & Err.Number _
          & "   DocumentHyperlinks by Crystal"

   Resume Proc_Exit
   Resume
End Sub

Sub Format_AutoFilter_Freeze( _
   pSht As Excel.Worksheet _
   , psLastCol As String _
   )
' 130816 Crystal
' Creative Commons license CC BY-NC-SA 3.0

   'Purpose:

   'Format the first row of the passed worksheet
   'and turn on AutoFilter
   'and freeze the top row
   
   'PARAMETERS
   
   '  pSht = reference to Excel sheet
   '  psLastCol = last column of labels (ie: "E")
      
   On Error GoTo Proc_Err
   
    With pSht
      With .Range("A1:E1")
         .Borders(xlDiagonalDown).LineStyle = xlNone
         .Borders(xlDiagonalUp).LineStyle = xlNone
         With .Borders(xlEdgeLeft)
             .LineStyle = xlContinuous
             .ColorIndex = 0
             .TintAndShade = 0
             .Weight = xlThin
         End With
         With .Borders(xlEdgeTop)
             .LineStyle = xlContinuous
             .ColorIndex = 0
             .TintAndShade = 0
             .Weight = xlThin
         End With
         With .Borders(xlEdgeBottom)
             .LineStyle = xlContinuous
             .ColorIndex = 0
             .TintAndShade = 0
             .Weight = xlThin
         End With
         With .Borders(xlEdgeRight)
             .LineStyle = xlContinuous
             .ColorIndex = 0
             .TintAndShade = 0
             .Weight = xlThin
         End With
         With .Borders(xlInsideVertical)
             .LineStyle = xlContinuous
             .ColorIndex = 0
             .TintAndShade = 0
             .Weight = xlThin
         End With
         With .Borders(xlInsideHorizontal)
             .LineStyle = xlContinuous
             .ColorIndex = 0
             .TintAndShade = 0
             .Weight = xlThin
         End With
         With .Interior
             .Pattern = xlSolid
             .PatternColorIndex = xlAutomatic
             .ThemeColor = xlThemeColorDark1
             .TintAndShade = -0.149998474074526
             .PatternTintAndShade = 0
         End With
      End With 'label range
      
      With .Range("A2")
         .Select
         .AutoFilter
      End With
      .Cells.EntireColumn.AutoFit
   End With 'sheet
   
   ActiveWindow.FreezePanes = True
   
Proc_Exit:
   On Error Resume Next
   Exit Sub

Proc_Err:
   MsgBox Err.Description, , _
          "ERROR " & Err.Number _
          & "   Format_AutoFilter_Freeze by Crystal"

   Resume Proc_Exit
   Resume
End Sub