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
