Add a Table of Contents to your Workbook Programmatically

Shouldn't the line:

    Set WST = Worksheets("Table of Contents")

be Set WST = Worksheets("TOC")

I ran this three times on a blank workbook and ended up with one TOC sheet and three sheets: Sheet1 (the original sheet), Sheet2, and Sheet3.

Thanks Gregory, I updated the post.

Thank you Bill,

If I may, see below update proposal.

Can't we eliminate the need of user action in closing the print preview. I tried "SendKeys()" without success.

Thank you, Serge.

---------------------------------------------

Option Explicit

Sub CreateTableOfContents()

   ' Determine if there is already a Table of Contents

   ' Assume it is there, and if it is not, it will raise an error

   ' if the Err system variable is > 0, you know the sheet is not there

   Dim WSTName As String      ' The Table of Content worksheet's name

   Dim s As Excel.Worksheet   ' Current worksheet in the loop

   Dim HPages As Long         ' Number of horizontal pages within current worksheet

   Dim VPages As Long         ' Number of vertical pages within current worksheet

   Dim ThisPages As Long      ' Total Number of pages within current worksheet

   Dim TOCTopRow As Integer   ' Row to place the TOC

   Dim TOCRow As Integer      ' Current row in Table of contents

   Dim PageCount As Long      ' Current count of pages within workbook

   WSTName = "Table of Contents"

   TOCTopRow = 2

   On Error Resume Next

   Worksheets(WSTName).Select

   If Not Err = 0 Then

       ' The Table of contents doesn't exist. Add it

       Worksheets.Add(Before:=Worksheets(1)).Name = WSTName

   End If

   On Error GoTo 0

   ' Set up the table of contents page

   With Worksheets(WSTName)

       .Select

       .Cells(TOCTopRow, 1) = WSTName

       With .Cells(TOCTopRow + 2, 1)

           .CurrentRegion.Clear

           .Value = "Subject"

       End With

       .Cells(TOCTopRow + 2, 2) = "Page(s)"

       .Range("A1:B1").ColumnWidth = Array(36, 12)

       .Columns(2).NumberFormat = "@"

       TOCRow = TOCTopRow + 3

       PageCount = 0

   ' Do a print preview on all sheets so Excel calcs page breaks

   ' The user must manually close the PrintPreview window

       MsgBox "Excel needs to do a print preview to calculate the number of pages. " & vbCrLf & _

              "Please dismiss the print preview by clicking close."

       ActiveWindow.SelectedSheets.PrintPreview

   ' Loop through each sheet, collecting TOC information

       For Each s In Worksheets

           If s.Visible = -1 Then

               HPages = s.HPageBreaks.Count + 1

               VPages = s.VPageBreaks.Count + 1

               ThisPages = HPages * VPages

               ' Enter info about this sheet on TOC

               .Cells(TOCRow, 1).Value = s.Name

               .Cells(TOCRow, 2).Value = PageCount + 1 & IIf(ThisPages <> 1, " - " & PageCount + ThisPages, "")

               PageCount = PageCount + ThisPages

               TOCRow = TOCRow + 1

           End If

       Next s

       Set s = Nothing

       .Select

       .[A2].Select

   End With

End Sub

I like the utility but have a question.  Why, when I have only a few columns and rows (would fit on one page) does the utility create multiple pages?

Instead of using the dialog, what happens if you select all sheets in the Workbook, temporarily, and flip in and out of Page Break Preview Mode? (with Screen Updating turned off temporarily as well)

can the code written so that there is hyperlink to the sheet in the table of content created? thanks.

Hi yp,

Under the "Enter info about this sheet on TOC" comment, if you replace the line:

Range("A" & TOCRow).Value = ThisName

With:

Sheets("TOC").Hyperlinks.Add Anchor:=Sheets("TOC").Range("A" & TOCRow), Address:="", _

           SubAddress:="'" & ThisName & "'!A1", _

           TextToDisplay:=ThisName

That will give you the hyperlink to the applicable sheet.

Thanks to XL-Dennis for that tip: http://xldennis.wordpress.com/