Summaries Workbook with Index Sheets Hyperlink

Summary of Workbook with Index of Sheets Automatically

(Excel VBA)

1. Hold down the ALT + F11 keys to open the Microsoft Visual Basic for Applications window.

2. Click Insert > Module, and paste the following code in the Module Window.

3. Then press F5 key to run this code

 

========

 
 Sub CreateTOC()
 Dim ws As Worksheet
 Dim nmToc As Name
 Dim rng1 As Range
 Dim lngProceed As Boolean
 Dim bNonWkSht As Boolean
 Dim lngSht As Long
 Dim lngShtNum As Long
 Dim strWScode As String
 Dim vbCodeMod

'Summary of ActiveWorkbook
 If ActiveWorkbook Is Nothing Then
 MsgBox "You must have a workbook open first!", vbInformation, "No Open Book"
 Exit Sub
 End If

'Turn off events for fast macro run
 With Application
 .ScreenUpdating = False
 .DisplayAlerts = False
 .EnableEvents = False
 End With

'If the Table of Contents exists (using a marker range name "TOC_Index") prompt the user whether to proceed
 On Error Resume Next
 Set nmToc = ActiveWorkbook.Names("TOC_Index")
 If Not nmToc Is Nothing Then
 lngProceed = MsgBox("Index exists!" & vbCrLf & "Do you want to overwrite it?", vbYesNo + vbCritical, "Warning")
 If lngProceed = vbYes Then
 Exit Sub
 Else
 ActiveWorkbook.Sheets(Range("TOC_Index").Parent.Name).Delete
 End If
 End If
 Set ws = ActiveWorkbook.Sheets.Add
 ws.Move before:=Sheets(1)
 'Add the marker range name
 ActiveWorkbook.Names.Add "TOC_INDEX", ws.[a1]
 ws.Name = "TOC_Index"
 On Error GoTo 0

On Error GoTo ErrHandler

For lngSht = 2 To ActiveWorkbook.Sheets.Count
 'set to start at A6 of TOC sheet
 'Test sheets to determine whether they are normal worksheets
 ws.Cells(lngSht + 4, 2).Value = TypeName(ActiveWorkbook.Sheets(lngSht))
 If TypeName(ActiveWorkbook.Sheets(lngSht)) = "Worksheet" Then
 'Add hyperlinks to normal worksheets
 ws.Hyperlinks.Add Anchor:=ws.Cells(lngSht + 4, 1), Address:="", SubAddress:="'" & ActiveWorkbook.Sheets(lngSht).Name & "'!A1", TextToDisplay:=ActiveWorkbook.Sheets(lngSht).Name
 Else
 'Add name of any non-worksheets
 ws.Cells(lngSht + 4, 1).Value = ActiveWorkbook.Sheets(lngSht).Name
 'Colour these sheets yellow
 ws.Cells(lngSht + 4, 1).Interior.Color = vbYellow
 ws.Cells(lngSht + 4, 2).Font.Italic = True
 bNonWkSht = True
 End If
 Next lngSht

'Add headers and formatting
 With ws
 With .[a1:a4]
 .Value = Application.Transpose(Array(ActiveWorkbook.Name, "", Format(Now(), "dd-mmm-yy hh:mm"), ActiveWorkbook.Sheets.Count - 1 & " sheets"))
 .Font.Size = 14
 .Cells(1).Font.Bold = True
 End With
 With .[a6].Resize(lngSht - 1, 1)
 .Font.Bold = True
 .Font.ColorIndex = 41
 .Resize(1, 2).EntireColumn.HorizontalAlignment = xlLeft
 .Columns("A:B").EntireColumn.AutoFit
 End With
 End With

'Add warnings and macro code if there are non WorkSheet types present
 If bNonWkSht Then
 With ws.[A5]
 .Value = "This workbook contains at least one Chart or Dialog Sheet. These sheets will only be activated if macros are enabled (NB: Please doubleclick yellow sheet names to select them)"
 .Font.ColorIndex = 3
 .Font.Italic = True
 End With
 strWScode = "Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)" & vbCrLf _
 & " Dim rng1 As Range" & vbCrLf _
 & " Set rng1 = Intersect(Target, Range([a6], Cells(Rows.Count, 1).End(xlUp)))" & vbCrLf _
 & " If rng1 Is Nothing Then Exit Sub" & vbCrLf _
 & " On Error Resume Next" & vbCrLf _
 & " If Target.Cells(1).Offset(0, 1) <> ""Worksheet"" Then Sheets(Target.Value).Activate" & vbCrLf _
 & " If Err.Number <> 0 Then MsgBox ""Could not select sheet"" & Target.Value" & vbCrLf _
 & "End Sub" & vbCrLf

Set vbCodeMod = ActiveWorkbook.VBProject.VBComponents(ws.CodeName)
 vbCodeMod.CodeModule.AddFromString strWScode
 End If

With Application
 .ScreenUpdating = True
 .DisplayAlerts = True
 .EnableEvents = True
 End With

ErrHandler:
 If Err.Number <> 0 Then MsgBox Err.Description & vbCrLf & "Please note that your Application settings have been reset", vbCritical, "Code Error!"
 End Sub

 

Share this post

Post Comment

sixteen + 15 =