SmittyPro - Witticisms, Help, Tutorials and More
Jan
29

Create a Table of Contents in Excel

written by Zack

Post to Twitter Post to Facebook Post to Google Buzz Post to LinkedIn Post to Technorati

There has always been a need for a good Table of Contents in Excel. While Word features this natively with its built-in Styles, unfortunately, Excel lacks this functionality due to a host of reasons, which are quite valid. However, we can create a workaround by incorporating some VBA.

The following code is an updated version I created a few years ago. It was simple and served my needs. Over the years it’s needed work, but like a mechanic with his own vehicle, I never really put the time forth to do it, always pushing it to the back burner. Not so anymore! Today I updated the code and made it much more versatile and dynamic! Plus I added comments, which are always helpful when looking back on it.

The code will now take any type of worksheet and create a hyperlink to it. Previously, the problem was if the user had a Dialog, Macro or Chart sheet in a workbook, standard hyperlinks do not work, as you can only use a standard hyperlink to a worksheet (all of the above objects are in the Sheets collection, but not a Worksheet type). In order to bypass this we can create a button on top of each unsupported object it which is linked to a procedure in a we have stored in a module. You can change the variables at the top of the module to whatever you’d like, but it will work as-is if you copy/paste to a new module. The code It will automatically change the name of the module to whatever you specify for the sModuleName variable.

Here is the code. If you have any comments, please feel free to let me know!

'---------------------------------------------------------------------------------------
' Module : Mod_TOC_RPA
' Author : Zack Barresse
' Updated : 1/27/2012
' Purpose : This code module serves as a stand-alone module to create a Table of
' Contents of the active workbook. The other sub routines are supportive
' of this functionality. This will handle the following sheet types:
' Worksheets
' Chart sheets
' Dialog sheets
' Macro sheets
' For those sheets which are not Worksheet types, a shape is utilized. This
' is done because you cannot hyperlink to these sheet types with the normal
' functionality. So instead we add the sheet name to it with an old
' Excel4Macro and add an OnAction property for it to use a sub routine. All
' other 'normal' worksheets will receive a hyperlink to that sheet, with a
' destination of cell A1.
' References: Microsoft Visual Basic for Applications Extensibility 5.3
' You must set this reference for the code to compile without error. To
' add this reference library, click Tools | References, find the correct
' reference, check the box next to it, then click Ok. If you don't see it
' in the list, look for it in its normal location:
' C:\Program Files (x86)\Common Files\microsoft shared\VBA\VBA6\VBE6EXT.OLB
' or
' C:\Program Files\Common Files\microsoft shared\VBA\VBA6\VBE6EXT.OLB
' Change the 'sModuleName' to whatever you want the module to be named.
' With the above reference, you can change it to whatever you want. If you
' name it to another module name that exists in the same project, the
' current module name will be retained.
' Examples : Some other examples of creating Table of Contents can be found here:
' http://dmcritchie.mvps.org/excel/buildtoc.htm
' http://www.vbaexpress.com/kb/getarticle.php?kb_id=120
' http://www.mrexcel.com/articles/table-of-contents-macro.php
' http://alturl.com/nrk83 **
' http://extremecpa.blogspot.com/2005/08/table-of-contents-in-excel-with-vba.html
' ** Like this code, will take any type of sheet (the others will fail),
' but uses VBA to write to the Table of Contents sheet code module
' for the functionality of hyperlinking.
'---------------------------------------------------------------------------------------

Option Explicit

Private Const sModuleName As String = "Module1"
Private Const sDefaultProcName As String = "CreateTOC"
Private Const sSheetName As String = "Table of Contents"
Private Const DNL As String = vbNewLine & vbNewLine
Private sModuleRename As String
Private sProcName As String
Private bModuleName As Boolean

'/// ***************************************************************************************
'/// MAIN ROUTINE
'/// ***************************************************************************************

Sub CreateTOC()
'---------------------------------------------------------------------------------------
' Procedure : CreateTOC
' Author : Zack Barresse
' Updated : 1/27/2012
' Purpose : Explicitly setting object references, cleaned up variables, added some
' additional error handling, added the handling of Macro and Dialog sheets
' as well, and generally cleaned up code.
'Thanks to : Ken Puls
' Simon Lloyd
' Anne Troy
'---------------------------------------------------------------------------------------
Dim VBComp As VBIDE.VBComponent
Dim CodeMod As VBIDE.CodeModule
Dim LineNum As Long
Dim ProcKind As VBIDE.vbext_ProcKind
Dim WB As Workbook
Dim WS As Worksheet
Dim cb As Shape
Dim iWriteToRow As Long
Dim iLoop As Long
Dim iWsTotalCnt As Long
Dim iWsCnt As Long
Dim iChartCnt As Long
Dim iOtherCnt As Long
Dim iLeft As Long
Dim iTop As Long
Dim iHeight As Long
Dim iWidth As Long
Dim iShade As Long
Dim sMsg As String
Dim sAddy As String
Dim shtName As String
Dim bTrigger As Boolean

'/// Used to get procedure name
bTrigger = True

'/// Check if there is an activeworkbook or not (i.e. this code was dropped into a
'/// workbook which wasn't visible, or an add-in)
If ActiveWorkbook Is Nothing Then
MsgBox "You must have a workbook open first!", vbInformation, "No Open Book"
Exit Sub
End If

'/// Set variables
iShade = 37
iWriteToRow = 3
iWsCnt = 0
Set WB = ActiveWorkbook

'/// Turn off some application settings to make code more efficient and run faster
Call TOGGLEEVENTS(False)

'/// Check if the TOC worksheet already exists in the workbook, and if so question user
If WSEXISTS(sSheetName, WB) = True Then
sMsg = "You already have a Table of Contents page. Would you like to overwrite it?"
If MsgBox(sMsg, vbYesNo + vbQuestion, "Replace TOC page?") = vbYes Then GoTo ExitEarly
WB.Worksheets(sSheetName).Delete
End If

'/// Add a blank worksheet to the far left, rename it
Set WS = WB.Worksheets.Add(before:=WB.Sheets(1))
WS.Name = sSheetName

'/// Ensure the code module is the proper name, as needed for the shape OnAction property
Call ChangeModuleName

'/// Change format of TOC sheet
WS.Cells.Interior.ColorIndex = iShade
WS.Rows("4:" & WS.Rows.Count).RowHeight = 16
WS.Range("A1").Font.Bold = False
WS.Range("A1").Font.Italic = True
WS.Range("A1").Font.Name = "Arial"
WS.Range("A1").Font.Size = "8"
WS.Range("A2").Value = "Table of Contents"
WS.Range("A2").Font.Bold = True
WS.Range("A2").Font.Name = "Arial"
WS.Range("A2").Font.Size = "24"
WS.Range("A4").Select

'/// Add a shape which will act as an update for the TOC sheet
With WS.Range("C1")
Set cb = WS.Shapes.AddShape(msoShapeRoundedRectangle, .Left, .Top, .Width, .Height)
End With
sAddy = "R1C3"
cb.Select
Selection.ShapeRange.Fill.ForeColor.SchemeColor = 0
Selection.ShapeRange.TextFrame.VerticalAlignment = xlCenter
Selection.Font.Underline = xlUnderlineStyleSingle
Selection.Font.ColorIndex = 5
Selection.ShapeRange.Fill.Visible = msoFalse
Selection.ShapeRange.Line.Visible = msoFalse

'/// Get the current routine name
'/// Kindly adapted from Chip Pearson, found at:
'/// http://www.cpearson.com/Excel/vbe.aspx
On Error GoTo ErrHandle
Set VBComp = ThisWorkbook.VBProject.VBComponents(sModuleName)
Set CodeMod = VBComp.CodeModule
LineNum = CodeMod.CountOfDeclarationLines + 1
sProcName = CodeMod.ProcOfLine(LineNum, ProcKind)
GoTo NoCodeModErr

ErrHandle:
'/// Code module was not found, use default
sProcName = sDefaultProcName

NoCodeModErr:
If sProcName = vbNullString Then sProcName = sDefaultProcName
Selection.OnAction = IIf(Len(sModuleRename) > 0, sModuleRename, sModuleName) & "." & sProcName

'/// Set heading text for TOC
WS.Range("C1").Value = "Update TOC"
WS.Range("C1").Interior.ColorIndex = iShade
WS.Range("C1").Font.Bold = True
WS.Range("C1").Font.Italic = True
WS.Range("C1").Font.Name = "Arial"
WS.Range("C1").Font.Size = "10"
WS.Range("C1").Font.Underline = xlUnderlineStyleSingle

'/// Get a total of the sheets
'/// NB: We do not use "WB.Worksheets.Count" as that will only count 'worksheets', which
'/// does not include chart sheets
iWsTotalCnt = WB.Sheets.Count

'/// Loop through all sheets, excluding the first (TOC) worksheet
For iLoop = 2 To iWsTotalCnt

'/// Set the write row, increment by 1 every iteration
iWriteToRow = iWriteToRow + 1

'/// Check if the sheet iteration is a chart sheet or not
If IsChart(WB.Sheets(iLoop).Name) Then

'///////////////////////////
'/// Sheet is a chart sheet
'///////////////////////////

'/// Get a total count of chart sheets, set variables
iChartCnt = iChartCnt + 1
shtName = WB.Charts(iChartCnt).Name
WS.Range("C" & iWriteToRow).Value = shtName
WS.Range("C" & iWriteToRow).Font.ColorIndex = iShade

'/// Get dimensions of write cell to apply button to it
iLeft = WS.Range("C" & iWriteToRow).Left
iTop = WS.Range("C" & iWriteToRow).Top
iWidth = WS.Range("C" & iWriteToRow).Width
iHeight = WS.Range("C" & iWriteToRow).RowHeight
sAddy = "R" & iWriteToRow & "C3"

'/// Add the shape to the correct cell, add text to it and assign macro "GotoChart"
Set cb = WS.Shapes.AddShape(msoShapeRoundedRectangle, iLeft, iTop, iWidth, iHeight)
cb.Select
ExecuteExcel4Macro "FORMULA(""=" & sAddy & """)"
Selection.ShapeRange.TextFrame.VerticalAlignment = xlCenter
Selection.ShapeRange.TextFrame.HorizontalAlignment = xlLeft
Selection.ShapeRange.Fill.ForeColor.SchemeColor = 0
Selection.Font.Underline = xlUnderlineStyleSingle
Selection.Font.ColorIndex = 5
Selection.ShapeRange.Fill.Visible = msoFalse
Selection.ShapeRange.Line.Visible = msoFalse
Selection.OnAction = IIf(Len(sModuleRename) > 0, sModuleRename, sModuleName) & ".GotoOther"

'/// Write number to TOC index
WS.Range("B" & iWriteToRow).Value = iLoop

ElseIf IsWorksheet(WB.Sheets(iLoop).Name, WB) = True Then

'/////////////////////////
'/// Sheet is a Worksheet
'/////////////////////////

'/// Grab count
iWsCnt = iWsCnt + 1

'/// Sheet is a regular worksheet
shtName = WB.Sheets(iLoop).Name
WS.Range("C" & iWriteToRow).Hyperlinks.Add Anchor:=WS.Range("C" & iWriteToRow), _
Address:="#'" & shtName & "'!A1", _
SubAddress:="#'" & shtName & "'!A1", _
TextToDisplay:=shtName
WS.Range("C" & iWriteToRow).HorizontalAlignment = xlLeft

'/// Write number to TOC index
WS.Range("B" & iWriteToRow).Value = iLoop

Else

'////////////////////////////////////
'/// Sheet is a dialog or macro sheet
'////////////////////////////////////

'/// Grab count
' iWsCnt = iWsCnt + 1

'/// Get a total count of chart sheets, set variables
iOtherCnt = iOtherCnt + 1
shtName = WB.Sheets(iLoop).Name
WS.Range("C" & iWriteToRow).Value = shtName
WS.Range("C" & iWriteToRow).Font.ColorIndex = iShade

'/// Get dimensions of write cell to apply button to it
iLeft = WS.Range("C" & iWriteToRow).Left
iTop = WS.Range("C" & iWriteToRow).Top
iWidth = WS.Range("C" & iWriteToRow).Width
iHeight = WS.Range("C" & iWriteToRow).RowHeight
sAddy = "R" & iWriteToRow & "C3"

'/// Add the shape to the correct cell, add text to it and assign macro "GotoChart"
Set cb = WS.Shapes.AddShape(msoShapeRoundedRectangle, iLeft, iTop, iWidth, iHeight)
cb.Select
ExecuteExcel4Macro "FORMULA(""=" & sAddy & """)"
Selection.ShapeRange.TextFrame.VerticalAlignment = xlCenter
Selection.ShapeRange.TextFrame.HorizontalAlignment = xlLeft
Selection.ShapeRange.Fill.ForeColor.SchemeColor = 0
Selection.Font.Underline = xlUnderlineStyleSingle
Selection.Font.ColorIndex = 5
Selection.ShapeRange.Fill.Visible = msoFalse
Selection.ShapeRange.Line.Visible = msoFalse
Selection.OnAction = IIf(Len(sModuleRename) > 0, sModuleRename, sModuleName) & ".GotoOther"

'/// Write number to TOC index
WS.Range("B" & iWriteToRow).Value = iLoop

End If

continueLoop:
Next iLoop

'/// Set viewing options
Sheets(sSheetName).Range("C:C").EntireColumn.ColumnWidth = 30
Sheets(sSheetName).Range("A4").Activate

'/// Add string to message prompt if there were any chart sheets added
If iChartCnt > 0 Then
sMsg = DNL & Space(13) & iChartCnt & " Chart sheets have been added"
End If

'/// Add string to message prompt if there were any dialog or macro sheets added
If iOtherCnt > 0 Then
sMsg = sMsg & DNL & Space(13) & iOtherCnt
sMsg = sMsg & " Other sheet" & IIf(iOtherCnt > 1, "s have", " has") & " been added (i.e. Dialog & Macro sheets)"
End If

'/// Append string to message prompt for how many worksheets were added
sMsg = sMsg & DNL & Space(13) & iWsCnt & " Worksheets have been added"

'/// If module name was changed, add that in the message prompt text
If bModuleName = True Then
MsgBox "Complete!" & vbNewLine & "The code module name was changed." & sMsg, vbInformation, "Complete!"
Else
MsgBox "Complete!" & sMsg, vbInformation, "Complete!"
End If

ExitEarly:
'/// Reset application settings back to default
Call TOGGLEEVENTS(True)

End Sub

'/// ***************************************************************************************
'/// SUPPORTIVE FUNCTIONS
'/// ***************************************************************************************

Public Sub TOGGLEEVENTS(blnState As Boolean)
'---------------------------------------------------------------------------------------
' Procedure : TOGGLEEVENTS
' Author : Zack Barresse
' Date : 1/27/2012
' Purpose : Quickly toggle application Properties instead of calling them in each procedure
' Variables : blnState - pass a true/false value indicated the property state desired
'---------------------------------------------------------------------------------------
If Not blnState Then Application.Calculation = xlCalculationManual
Application.DisplayAlerts = blnState
Application.EnableEvents = blnState
Application.ScreenUpdating = blnState
If blnState Then Application.CutCopyMode = False
If blnState Then Application.StatusBar = False
If blnState Then Application.Calculation = xlCalculationAutomatic
End Sub

Public Function WSEXISTS(wksName As String, Optional WKB As Workbook) As Boolean
'---------------------------------------------------------------------------------------
' Procedure : WSEXISTS
' Author : Zack Barresse
' Date : 1/27/2012
' Purpose : To test whether a worksheet exists in a workbook or not
' Variables : wksName - pass a string name for a sheet to test for
' WKB - optionally pass a workbook to test the sheet in, if not specified
' the active workbook will be used
'---------------------------------------------------------------------------------------
If WKB Is Nothing Then
If ActiveWorkbook Is Nothing Then Exit Function
Set WKB = ActiveWorkbook
End If
On Error Resume Next
WSEXISTS = CBool(WKB.Sheets(wksName).Name <> "")
On Error GoTo 0
End Function

Public Function IsWorksheet(shNameTemp As String, Optional WKB As Workbook) As Boolean
'---------------------------------------------------------------------------------------
' Procedure : IsWorksheet
' Author : Zack Barresse
' Date : 1/27/2012
' Purpose : To discern whether or not a sheet in a given workbook is an actual
' worksheet, as opposed to a macro, dialog or chart sheet.
' Variables : shNameTemp - pass a string name for a sheet to test for
' WKB - optionally pass a workbook to test the sheet in, if not specified
' the active workbook will be used
'---------------------------------------------------------------------------------------
Dim wksTemp As Worksheet
If WKB Is Nothing Then
If ActiveWorkbook Is Nothing Then Exit Function
Set WKB = ActiveWorkbook
End If
On Error GoTo ErrFound
'/// Macro and Dialog sheets will throw an error in one of the next two lines
Set wksTemp = WKB.Sheets(shNameTemp)
If wksTemp.Name = wksTemp.CodeName Then
IsWorksheet = TypeName(WKB.Sheets(shNameTemp)) = "Worksheet"
End If
ErrFound:
On Error GoTo 0
End Function

Public Function IsChart(chtName As String) As Boolean
'---------------------------------------------------------------------------------------
' Procedure : IsChart
' Author : Zack Barresse
' Updated : 1/27/2012
' Purpose : Check if the name passed is a Chart sheet or not
'---------------------------------------------------------------------------------------
On Error Resume Next
IsChart = CBool(ActiveWorkbook.Charts(chtName).Name <> "")
On Error GoTo 0
End Function

Private Sub GotoOther()
'---------------------------------------------------------------------------------------
' Procedure : GotoOther
' Author : Zack Barresse
' Date : 1/27/2012
' Purpose : Attached to a shape to allow for hyperlinking to other sheets
'---------------------------------------------------------------------------------------
Dim obj As Shape
Dim objName As String
On Error Resume Next
Set obj = ActiveSheet.Shapes(Application.Caller)
objName = obj.TopLeftCell.Value
ActiveWorkbook.Sheets(objName).Activate
On Error GoTo 0
End Sub

Sub ChangeModuleName()
'---------------------------------------------------------------------------------------
' Procedure : ChangeModuleName
' Author : Simon Lloyd
' Date : 4/20/2011
' Purpose : Check if a code module name already exists, if not, create it
'---------------------------------------------------------------------------------------
Dim vbModule As VBIDE.VBComponent
bModuleName = False
If VBComponentExists(sModuleName, ThisWorkbook.VBProject) = False Then
Call fxModuleNameChange(sModuleName, ThisWorkbook)
bModuleName = True
End If
End Sub

Public Sub fxModuleNameChange(newMacro As String, Optional WB As Workbook)
'---------------------------------------------------------------------------------------
' Procedure : fxModuleNameChange
' Author : Simon Lloyd
' Date : 4/20/2011
' Purpose : Change a module name
' Variables : newMacro - pass a string name for a module name to change to
' : WB - optionally pass a workbook to look in
'---------------------------------------------------------------------------------------
Dim VBC As VBIDE.VBComponent, modCode As String
If WB Is Nothing Then Set WB = ThisWorkbook
For Each VBC In WB.VBProject.VBComponents
If VBC.CodeModule.CountOfLines > 0 Then
modCode = VBC.CodeModule.Lines(1, VBC.CodeModule.CountOfLines)
If InStr(1, modCode, newMacro, vbTextCompare) > 0 Then
VBC.Name = sModuleName
Exit For
End If
End If
Next VBC
End Sub

Public Function VBComponentExists(VBCompName As String, Optional VBProj As VBIDE.VBProject = Nothing) As Boolean
'---------------------------------------------------------------------------------------
' Procedure : VBComponentExists
' Author : Simon Lloyd
' Date : 4/20/2011
' Purpose : Check to see if a code module already exists. If it does, and if the name
' is not equal to the current module name (which will result in shape
' hyperlinks being broken) then set the sModuleRename variable to the
' current module name
' Variables : VBCompName - pass a string name to check if it exists
' : VBProj - otionally pass a specific project (workbook) to look in
'---------------------------------------------------------------------------------------
Dim VBP As VBIDE.VBProject
If VBProj Is Nothing Then
Set VBP = ActiveWorkbook.VBProject
Else
Set VBP = VBProj
End If
On Error Resume Next
sModuleRename = vbNullString
VBComponentExists = CBool(Len(VBP.VBComponents(VBCompName).Name))
If VBComponentExists And VBCompName <> VBP.VBE.ActiveCodePane.CodeModule Then
sModuleRename = VBP.VBE.ActiveCodePane.CodeModule
End If
End Function

Copy, paste, run CreateTOC. Done. :)

NB: There is a link in the comments section of the code created from ShortURL.com, to which the full link is:
http://www.experts-exchange.com/Software/Office_Productivity/Office_Suites/MS_Office/Excel/A_3515-Excel-VBA-to-create-a-Table-of-Contents-TOC-summary-sheet.html

This was code written by Dave Brett (brettdj) which is just as functional as this (unlike most other code out there to create a Table of Contents), but his differs from this functionally in that he used VBA to write code to the worksheet itself as an event, which is quite ingenious.

Many thanks to Simon Lloyd, Ken Puls, Anne Troy, Chip Pearson, for helping with pieces of code, testing, and inspiration. :)

Post to Twitter Post to Facebook Post to Google Buzz Post to LinkedIn Post to Technorati

2 Responses to “Create a Table of Contents in Excel”

  1. Jeff

    Really intricate piece of work, folks, thanks. I’m not the best VBA programmer, so seeing this kind of high level stuff in action is really helpful for learning how to use the more advanced functions.

    I’ve run into one small problem, though. Using MS Excel 2010, I pasted this text verbatim into a new module and ran it but got an error saying:

    Compile error:
    User-defined type not defined

    At the line –
    Public Function VBComponentExists(VBCompName As String, Optional VBProj As VBIDE.VBProject = Nothing) As Boolean

    Thoughts?

  2. Hi Jeff,

    It is probably failing because you don’t have the proper reference set. Look in the comments of the code. You will find…

    ———
    ‘ References: Microsoft Visual Basic for Applications Extensibility 5.3
    ‘ You must set this reference for the code to compile without error. To
    ‘ add this reference library, click Tools | References, find the correct
    ‘ reference, check the box next to it, then click Ok. If you don’t see it
    ‘ in the list, look for it in its normal location:
    ‘ C:\Program Files (x86)\Common Files\microsoft shared\VBA\VBA6\VBE6EXT.OLB
    ‘ or
    ‘ C:\Program Files\Common Files\microsoft shared\VBA\VBA6\VBE6EXT.OLB
    ———-

    There are other comments as well, which you should read.

    Regards,
    Zack Barresse

Leave a Comment - Here's your chance to speak.(eMail will not be published)

Tags:
Separate individual tags by commas

Before you post, please prove you are sentient.

What is 7 multiplied by 7?

Microsoft MVP

 

Join In

Tag Cloud

Great Links

Archives

SmittyPro.com

Welcome to SmittyPro.com, your one-stop for solutions concerning anything from beginner to extremely advanced Microsoft Excel issues and programming. Topics covered include Excel, Access, VBA, and (every now and then) some amazing observations or "Smitticisms" that might dumbfound you and send ripples of excitement or intrigue around the world.

Categories

Meta

RSS Top Stories from CNN

Vistor Counter for SmittyPro's Blog