Create a Table of Contents in Excel for a Price List

Today's challenge was to create a table of contents in Excel, for a downloaded price list. The data came from Crystal Reports and had formatting on the section headings. Some of the headings were repeated, but we didn't want the TOC to include the duplicates.

I've created a table of contents based on sheet names, in other workbooks, but hadn't tried to index a sheet's contents. In this case, all the heading cells were blue, so I decided to create a a TOC entry for any blue cell. A quick test in the Immediate window showed me the colour index -- 42.

The code checks for a TOC sheet, deletes the old one, if it exists, then creates a new TOC sheet. The first instance of each heading is added to the TOC sheet, with a hyperlink to the cell where that heading is located.

The price list has a few hundred product categories, so at the end of the code an AutoFilter is added to the TOC, to make it easier to find the product that you want.

The CreateHyperlinks Code

Here's the code that I used, and you can add your own error handling. You can also download the sample Hyperlink TOC file (Excel 2007 format).

Sub CreateHyperlinks()

Dim c As Range

Dim ws As Worksheet

Dim wsTOC As Worksheet

Dim lRowTOC As Long

Dim lColor As Long

Dim strTOC As String

Dim strHead As String
lRowTOC = 2

lColor = 42

strTOC = "TOC"

strHead = ""
On Error Resume Next

Application.DisplayAlerts = False

Worksheets(strTOC).Delete

Application.DisplayAlerts = True

On Error GoTo 0
Set wsTOC = Worksheets.Add

With wsTOC

    .Name = strTOC

    .Cells(1, 1).Value = "Product"

    .Cells(1, 1).Font.Bold = True

End With
For Each ws In ThisWorkbook.Worksheets

    If ws.Name <> strTOC Then

        For Each c In ws.UsedRange.Columns(1).Cells

            If c.Interior.ColorIndex = lColor Then

                'don't index duplicate headings

                If strHead <> c.Value Then

                    wsTOC.Cells(lRowTOC, 1).Value = c.Value

                    wsTOC.Hyperlinks.Add _

                        Anchor:=wsTOC.Cells(lRowTOC, 1), _

                        Address:="", _

                        SubAddress:=c.Parent.Name  _

                        & "!" & c.Address, _

                        TextToDisplay:=c.Value

                    lRowTOC = lRowTOC + 1

                    strHead = c.Value

                End If

            End If

        Next c

    End If

Next ws
wsTOC.Columns(1).AutoFilter

wsTOC.Columns(1).AutoFit
End Sub

___________________