Create A Table Of Contents

6 minute read

This one is pretty sweet. It creates a nicely formatted TOC sheet and a back button on each sheet that links to the TOC. If you happen to add a sheet, simply click the delete back button then click refresh buttons to simply Refresh!

' ======================================================================================================
' ## Master macro which calls all of the other Sub Routines
' ======================================================================================================
Sub MasterTOC() TOC_DeleteBackButton ' Deletes Back Buttons on each sheet TableOfContents_Create ' Creates a Table of Contents sheet named 'TableOfContents' Contents_Hyperlinks ' Deletes Back Buttons on the sheets and creates a new button ContentsButtons ' Creates the Refresh and the Delete Back Buttons on the Contents Page
End Sub ' ======================================================================================================
' ## Deletes Back Buttons on each sheet
' ======================================================================================================
Sub DeleteBackButton()
' Vars Dim sht As Worksheet Dim shp As Shape Dim ContentName As String Dim ButtonID As String ContentName = "TableOfContents" 'Table of Contents Worksheet Name ButtonID = "_ContentButton" 'ID to Track Buttons for deletion ' Loop Through Each Worksheet in Workbook For Each sht In ActiveWorkbook.Worksheets If sht.Name  ContentName Then ' Delete Old Button (if necessary when refreshing) For Each shp In sht.Shapes If Right(shp.Name, Len(ButtonID)) = ButtonID Then shp.Delete 'Exit For End If Next shp End If Next sht
End Sub ' ======================================================================================================
' ## Creates a Table of Contents sheet named 'TableOfContents'
' ======================================================================================================
Sub TableOfContents_Create() ' Vars Dim sht As Worksheet Dim Content_sht As Worksheet Dim myArray As Variant Dim x As Long, y As Long, z As Long Dim shtName1 As String, shtName2 As String Dim ContentName As String Dim shtCount As Long Dim ColumnCount As Variant Dim shtCountOne As Boolean ' Optimize Application.DisplayAlerts = False Application.ScreenUpdating = False ContentName = "TableOfContents" ' Delete Contents Sheet if it already exists On Error Resume Next Worksheets("TableOfContents").Activate On Error GoTo 0 If ActiveSheet.Name = ContentName Then myAnswer = MsgBox("A worksheet named [" & ContentName & _ "] has already been created, would you like to replace it?", vbYesNo) ' Did user select No or Cancel? If myAnswer  vbYes Then GoTo ExitSub ' Delete old Contents Tab If Worksheets.Count = 1 Then Worksheets.Add After:=Worksheets(1) shtCountOne = True End If Worksheets(ContentName).Delete End If ' Count how many Visible sheets there are For Each sht In ActiveWorkbook.Worksheets If sht.Visible = True Then shtCount = shtCount + 1 Next sht ' Column count, I have commented out the InputBox option ' ColumnCount = 3 ColumnCount = Application.InputBox("You have " & shtCount & _ " visible worksheets." & vbNewLine & "How many columns " & _ "would you like to have in your Contents tab?", Type:=2) ' Check if user cancelled, uncomment this for the InputBox option If TypeName(ColumnCount) = "Boolean" Or ColumnCount < 0 Then GoTo ExitSub ' Create New Contents Sheet Worksheets.Add Before:=Worksheets(1) ' Set variable to Contents Sheet and Rename Set Content_sht = ActiveSheet Content_sht.Name = ContentName ' Create Array list with sheet names (excluding Contents) ReDim myArray(1 To shtCount) For Each sht In ActiveWorkbook.Worksheets If sht.Name  ContentName And sht.Visible = True Then myArray(x + 1) = sht.Name x = x + 1 End If Next sht ' Alphabetize Sheet Names in Array List For x = LBound(myArray) To UBound(myArray) For y = x To UBound(myArray) If UCase(myArray(y)) < UCase(myArray(x)) Then shtName1 = myArray(x) shtName2 = myArray(y) myArray(x) = shtName2 myArray(y) = shtName1 End If Next y Next x ' Create Table of Contents x = 1 For y = 1 To ColumnCount For z = 1 To WorksheetFunction.RoundUp(shtCount / ColumnCount, 0) If x

Leave a Comment