Auto Content page

handbtys

New Member
Joined
May 11, 2005
Messages
49
Hi,

I'm working on a large spreadsheet with plenty of worksheets.

Is it possible to have a macro that creates a content page?

ie. In a column on the current worksheet, it will place the names of all the worksheets and hyperlinks to all the worksheets.

I found the following code online and it does most of the work, except for placing the hyperlink. Can anyone help?

Code:
Sub GenerateTableOfContents()

' Does a TOC already exist?
' If Err system variable is > 0, it doesn't
Dim wSheet As Worksheet
On Error Resume Next
Set wSheet = Worksheets("Table of Contents")
If Not Err = 0 Then
' The Table of contents doesn't exist. Add it
Set wSheet = Worksheets.Add(Before:=Worksheets(1))
wSheet.Name = "TOC"
End If
On Error GoTo 0

' Set up the table of contents page
wSheet.[A2] = "Table of Contents"
With wSheet.[A6]
.CurrentRegion.Clear
.Value = "Subject"
End With
wSheet.[B6] = "Page(s)"
wSheet.Range("A1:B1").ColumnWidth = Array(36, 12)
TableRow = 7
PageCount = 0
Worksheets.Select
displayMessage = "We'll do a Print Preview for some calculations."
displayMessage = displayMessage & "Please ‘Close' the window when it appears."
MsgBox displayMessage
ActiveWindow.SelectedSheets.PrintPreview

' Now loop thru sheets, collecting TOC info
For Each S In Worksheets
S.Select
ThisName = S.Name
HPages = S.HPageBreaks.Count + 1
VPages = S.VPageBreaks.Count + 1
ThisPages = HPages * VPages

' Enter info about this sheet on TOC
wSheet.Cells(TableRow, 1).Value = ThisName
wSheet.Cells(TableRow, 2).NumberFormat = "@"
If ThisPages = 1 Then
wSheet.Cells(TableRow, 2).Value = PageCount + 1 & " "
Else
wSheet.Cells(TableRow, 2).Value = PageCount + 1 & " - " & PageCount + ThisPages
End If
PageCount = PageCount + ThisPages
TableRow = TableRow + 1
Next S

End Sub
 

Some videos you may like

Excel Facts

How to total the visible cells?
From the first blank cell below a filtered data set, press Alt+=. Instead of SUM, you will get SUBTOTAL(9,)

pgc01

MrExcel MVP
Joined
Apr 25, 2006
Messages
19,870
Hi handbtys

...the names of all the worksheets and hyperlinks to all the worksheets...

If what you want is an easy way to jump directly to one worksheet, you already have that. Right-click on the worksheets scrolling arrows at the bottom left of the page.

Hope this helps
PGC
 

handbtys

New Member
Joined
May 11, 2005
Messages
49
Hi,

that would work, but I've something like 50 sheets in this workbook. It makes it that much harder to scroll along the sheets.

Ordinarily I would have split them up but in this case, they all help to "support" each other.

Any idea anyone?
 

DominicB

Well-known Member
Joined
Oct 3, 2005
Messages
1,569
Good morning handbtys

My add-in available via the link below, has this functionality. This is the code that I used :

Sub Indexer()
If ActiveSheet Is Nothing Then Exit Sub
Dim ShIndex, I, Response
Response = MsgBox("This utility will add an index sheet to your project listing all" & Chr(13) & "the sheets by name. Selecting the Yes option below will" & Chr(13) & "add hyperlinks to this index making it easier for users to" & Chr(13) & "navigate via mouse clicks, or select Cancel to quit without" & Chr(13) & "creating an index." & Chr(13) & Chr(13), vbYesNoCancel, "Ultimate Add-In : Create Index Sheet")
If Response = vbCancel Then Exit Sub
Set ShIndex = Sheets.Add(Type:=xlWorksheet)
If Response = vbNo Then
For I = 1 To Sheets.Count
ShIndex.Cells(I, 1).Value = Sheets(I).Name
Next I
End If
If Response = vbYes Then
For I = 1 To Sheets.Count
ActiveSheet.Hyperlinks.Add Anchor:=Cells(I, 1), Address:="", SubAddress:="'" & Sheets(I).Name & "'!A1", TextToDisplay:=Sheets(I).Name
Next I
End If
MsgBox "The index sheet has now been created."
End Sub

HTH

DominicB
 

handbtys

New Member
Joined
May 11, 2005
Messages
49

ADVERTISEMENT

Thank you! Elegant code and worked perfect. :biggrin:
 

Richard Schollar

MrExcel MVP
Joined
Apr 19, 2005
Messages
23,707
Hi Handbtys

FireFytr has some swish code for this which you might like to investigate:

Code:
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

This was sourced from VBAExpress.
 

S.H.A.D.O.

Well-known Member
Joined
Sep 6, 2005
Messages
1,915

ADVERTISEMENT

Hi Richard,

I have been Following this Thread from the Side Lines.
I just Tried Out the Code you Posted, it is Brilliant.
The Only thing is that it does Miss the Last Sheet Out.
Thanks SOOOO Much for Posting FireFytr's Code, I will Certainly be Using that Myself in the Future.

All the Best.
SHADO
 

S.H.A.D.O.

Well-known Member
Joined
Sep 6, 2005
Messages
1,915
Hi Again,

With my Limited Knowledge of VBA I have Tried to Adapt the Code so it Picks Up the Last Sheet, but to NO Avail.
I am Sure it is an Easy Change for One of the Many Great Experts on this Forum.

All the Best.
SHADO
 

S.H.A.D.O.

Well-known Member
Joined
Sep 6, 2005
Messages
1,915
Has Anybody had a Chance to have a Look or Adapt this Yet Please.

All the Best.
SHADO
 

Watch MrExcel Video

Forum statistics

Threads
1,113,791
Messages
5,544,302
Members
410,601
Latest member
Silver2
Top