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
|