Excel

Create a Table of Contents

Ease of Use

Easy

Version tested with

2000, 2002, 2003 

Submitted by:

Zack Barresse

Description:

This code creates/updates a Table of Contents for a specific workbook. 

Discussion:

As often as is the case, workbooks become tiresome to navigate through the sheet tab buttons. This code will allow you to quickly and easily setup a Table of Contents for a specific workbook and have each sheet name numbered chronologically as hyperlinks to those specific sheets. Each hyperlink will bring you to cell A1 of that sheet. If desired, you can create a hyperlink back to the Table of Contents as for a well-rounded navigation system. This is especially good on larger workbooks. UPDATED: This will create a hyperlink to Chart sheets as well, with some additional programming. Note: This procedure was originally intended for use in a Personal.xls (global) file. IsChart function from here: http://www.vbaexpress.com/kb/getarticle.php?kb_id=389. 

Code:

instructions for use

			

Option Explicit Sub CreateTOC() 'Declare all variables Dim ws As Worksheet, curws As Worksheet, shtName As String Dim nRow As Long, i As Long, N As Long, x As Long, tmpCount As Long Dim cLeft, cTop, cHeight, cWidth, cb As Shape, strMsg As String Dim cCnt As Long, cAddy As String, cShade As Long 'Check if a workbook is open or not. If no workbook is open, quit. If ActiveWorkbook Is Nothing Then MsgBox "You must have a workbook open first!", vbInformation, "No Open Book" Exit Sub End If '------------------------------------------------------------------------------- cShade = 37 '<<== SET BACKGROUND COLOR DESIRED HERE '------------------------------------------------------------------------------- 'Turn off events and screen flickering. Application.ScreenUpdating = False Application.DisplayAlerts = False nRow = 4: x = 0 'Check if sheet exists already; direct where to go if not. On Error Goto hasSheet Sheets("TOC").Activate 'Confirm the desire to overwrite sheet if it exists already. If MsgBox("You already have a Table of Contents page. Would you like to overwrite it?", _ vbYesNo + vbQuestion, "Replace TOC page?") = vbYes Then Goto createNew Exit Sub hasSheet: x = 1 'Add sheet as the first sheet in the workbook. Sheets.Add before:=Sheets(1) Goto hasNew createNew: Sheets("TOC").Delete Goto hasSheet hasNew: 'Reset error statment/redirects On Error Goto 0 'Set chart sheet varible counter tmpCount = ActiveWorkbook.Charts.Count If tmpCount > 0 Then tmpCount = 1 'Set a little formatting for the TOC sheet. ActiveSheet.Name = "TOC" With Sheets("TOC") .Cells.Interior.ColorIndex = cShade .Rows("4:65536").RowHeight = 16 .Range("A1").Value = "Designed by VBAX" .Range("A1").Font.Bold = False .Range("A1").Font.Italic = True .Range("A1").Font.Name = "Arial" .Range("A1").Font.Size = "8" .Range("A2").Value = "Table of Contents" .Range("A2").Font.Bold = True .Range("A2").Font.Name = "Arial" .Range("A2").Font.Size = "24" .Range("A4").Select End With 'Set variables for loop/iterations N = ActiveWorkbook.Sheets.Count + tmpCount If x = 1 Then N = N - 1 For i = 2 To N With Sheets("TOC") 'Check if sheet is a chart sheet. If IsChart(Sheets(i).Name) Then '** Sheet IS a Chart Sheet cCnt = cCnt + 1 shtName = Charts(cCnt).Name .Range("C" & nRow).Value = shtName .Range("C" & nRow).Font.ColorIndex = cShade 'Set variables for button dimensions. cLeft = .Range("C" & nRow).Left cTop = .Range("C" & nRow).Top cWidth = .Range("C" & nRow).Width cHeight = .Range("C" & nRow).RowHeight cAddy = "R" & nRow & "C3" 'Add button to cell dimensions. Set cb = .Shapes.AddShape(msoShapeRoundedRectangle, _ cLeft, cTop, cWidth, cHeight) cb.Select 'Use older technique to add Chart sheet name to button text. ExecuteExcel4Macro "FORMULA(""=" & cAddy & """)" 'Format shape to look like hyperlink and match background color (transparent). With Selection .ShapeRange.Fill.ForeColor.SchemeColor = 0 With .Font .Underline = xlUnderlineStyleSingle .ColorIndex = 5 End With .ShapeRange.Fill.Visible = msoFalse .ShapeRange.Line.Visible = msoFalse .OnAction = "Mod_Main.GotoChart" End With Else '** Sheet is NOT a Chart sheet. shtName = Sheets(i).Name 'Add a hyperlink to A1 of each sheet. .Range("C" & nRow).Hyperlinks.Add _ Anchor:=.Range("C" & nRow), Address:="#'" & _ shtName & "'!A1", TextToDisplay:=shtName .Range("C" & nRow).HorizontalAlignment = xlLeft End If .Range("B" & nRow).Value = nRow - 2 nRow = nRow + 1 End With continueLoop: Next i 'Perform some last minute formatting. With Sheets("TOC") .Range("C:C").EntireColumn.AutoFit .Range("A4").Activate End With 'Turn events back on. Application.DisplayAlerts = True Application.ScreenUpdating = True strMsg = vbNewLine & vbNewLine & "Please note: " & _ "Charts will have hyperlinks associated with an object." 'Toggle message box for chart existence or not, information only. If cCnt = 0 Then strMsg = "" MsgBox "Complete!" & strMsg, vbInformation, "Complete!" End Sub Public Function IsChart(cName As String) As Boolean 'Will return True or False if sheet is a Chart sheet object or not. 'Can be used as a worksheet function. Dim tmpChart As Chart On Error Resume Next 'If not a chart, this line will error out. Set tmpChart = Charts(cName) 'Function will be determined if the variable is now an Object or not. IsChart = IIf(tmpChart Is Nothing, False, True) End Function Private Sub GotoChart() 'This routine written to be assigned to button Object for Chart sheets only 'as Chart sheets don't have cell references to hyperlink to. Dim obj As Object, objName As String 'With the button text as the Chart name, we use the Caller method to obtain it. Set obj = ActiveSheet.Shapes(Application.Caller) 'The latter portion of the AlternativeText will give us the exact Chart name. objName = Trim(Right(obj.AlternativeText, Len(obj.AlternativeText) - _ InStr(1, obj.AlternativeText, ": "))) 'Then we can perform a standard Chart sheet Activate method using the variable. Charts(objName).Activate 'Optional: zoom Chart sheet to fit screen. 'Depending on screen resolution, this may need adjustment(s). ActiveWindow.Zoom = 80 End Sub

How to use:

  1. Copy above code.
  2. In Excel press Alt + F11 to enter the VBE.
  3. Press Ctrl + R to show the Project Explorer.
  4. Right-click desired file on left.
  5. Choose Insert -Module.
  6. Paste code into the right pane.
  7. Press Alt + Q to close the VBE.
  8. Save workbook before any other changes.
  9. Press Alt + F8, select 'CreateTOC', press Run.
 

Test the code:

  1. From an existing workbook, save first.
  2. Press Alt + F8.
  3. Choose 'CreateTOC'.
  4. Press 'Run'.
  5. TOC sheet will be the left-most sheet added in your workbook.
 

Sample File:

CreateTOCex.zip 20.98KB 

Approved by mdmackillop


This entry has been viewed 2942 times.

Please read our Legal Information and Privacy Policy
Copyright @2004 - 2014 VBA Express