I am looking to create a table of contents page that has:
-Multiple Columns
-Auto updates as tabs are added/deleted
-Has the cell color match the respective tab color
-Creates a hyperlink on each tab directing back to the TOC page
So far, I have found the following codes that have helped create the multiple columns and the hyperlinks. But, I am hoping to find something that will auto-update and change the cell color. I am not a coder (this is the first time I've ever tried to use code) and don't know what any of the stuff means, but hoping someone can help. Is it possible to combine all of these into one? Hopefully what I am asking makes sense. Thanks for the help!
Code that I used on a sheet to create TOC page:
Code used on the TOC page to create the hyperlinks:
-Multiple Columns
-Auto updates as tabs are added/deleted
-Has the cell color match the respective tab color
-Creates a hyperlink on each tab directing back to the TOC page
So far, I have found the following codes that have helped create the multiple columns and the hyperlinks. But, I am hoping to find something that will auto-update and change the cell color. I am not a coder (this is the first time I've ever tried to use code) and don't know what any of the stuff means, but hoping someone can help. Is it possible to combine all of these into one? Hopefully what I am asking makes sense. Thanks for the help!
Code that I used on a sheet to create TOC page:
VBA Code:
Sub TableOfContents_Create()
'PURPOSE: Add a Table of Contents worksheets to easily navigate to any tab (multiple columns)
'SOURCE: [URL='http://www.TheSpreadsheetGuru.com']www.TheSpreadsheetGuru.com[/URL]
Dim sht As Worksheet
Dim Content_sht As Worksheet
Dim myArray As Variant
Dim x As Long, y As Long, z As Long
Dim shtName1 As String, shtName2 As String
Dim ContentName As String
Dim shtCount As Long
Dim ColumnCount As Variant
'Inputs
ContentName = "Contents"
'Optimize Code
Application.DisplayAlerts = False
Application.ScreenUpdating = False
'Delete Contents Sheet if it already exists
On Error Resume Next
Worksheets("Contents").Activate
On Error GoTo 0
If ActiveSheet.Name = ContentName Then
myAnswer = MsgBox("A worksheet named [" & ContentName & _
"] has already been created, would you like to replace it?", vbYesNo)
'Did user select No or Cancel?
If myAnswer <> vbYes Then GoTo ExitSub
'Delete old Contents Tab
Worksheets(ContentName).Delete
End If
'Count how many Visible sheets there are
For Each sht In ActiveWorkbook.Worksheets
If sht.Visible = True Then shtCount = shtCount + 1
Next sht
'Ask how many columns to have
ColumnCount = Application.InputBox("You have " & shtCount & _
" visible worksheets." & vbNewLine & "How many columns " & _
"would you like to have in your Contents tab?", Type:=2)
'Check if user cancelled
If TypeName(ColumnCount) = "Boolean" Or ColumnCount < 0 Then GoTo ExitSub
'Create New Contents Sheet
Worksheets.Add Before:=Worksheets(1)
'Set variable to Contents Sheet and Rename
Set Content_sht = ActiveSheet
Content_sht.Name = ContentName
'Create Array list with sheet names (excluding Contents)
ReDim myArray(1 To shtCount)
For Each sht In ActiveWorkbook.Worksheets
If sht.Name <> ContentName And sht.Visible = True Then
myArray(x + 1) = sht.Name
x = x + 1
End If
Next sht
'Alphabetize Sheet Names in Array List
For x = LBound(myArray) To UBound(myArray)
For y = x To UBound(myArray)
If UCase(myArray(y)) < UCase(myArray(x)) Then
shtName1 = myArray(x)
shtName2 = myArray(y)
myArray(x) = shtName2
myArray(y) = shtName1
End If
Next y
Next x
'Create Table of Contents
x = 1
For y = 1 To ColumnCount
For z = 1 To WorksheetFunction.RoundUp(shtCount / ColumnCount, 0)
If x <= UBound(myArray) Then
Set sht = Worksheets(myArray(x))
sht.Activate
With Content_sht
.Hyperlinks.Add .Cells(z + 2, 2 * y), "", _
SubAddress:="'" & sht.Name & "'!A1", _
TextToDisplay:=sht.Name
End With
x = x + 1
End If
Next z
Next y
'Select Content Sheet and clean up a little bit
Content_sht.Activate
Content_sht.UsedRange.EntireColumn.AutoFit
ActiveWindow.DisplayGridlines = False
'Format Contents Sheet Title
With Content_sht.Range("B1")
.Value = "Table of Contents"
.Font.Bold = True
.Font.Size = 18
End With
ExitSub:
'Optimize Code
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Code used on the TOC page to create the hyperlinks:
VBA Code:
Sub Contents_Hyperlinks()
'PURPOSE: Add hyperlinked buttons back to Table of Contents worksheet tab
'SOURCE: [URL='http://www.TheSpreadsheetGuru.com']www.TheSpreadsheetGuru.com[/URL]
Dim sht As Worksheet
Dim shp As Shape
Dim ContentName As String
Dim ButtonID As String
'Inputs:
ContentName = "Contents" 'Table of Contents Worksheet Name
ButtonID = "_ContentButton" 'ID to Track Buttons for deletion
'Loop Through Each Worksheet in Workbook
For Each sht In ActiveWorkbook.Worksheets
If sht.Name <> ContentName Then
'Delete Old Button (if necessary when refreshing)
For Each shp In sht.Shapes
If Right(shp.Name, Len(ButtonID)) = ButtonID Then
shp.Delete
Exit For
End If
Next shp
'Create & Position Shape
Set shp = sht.Shapes.AddShape(msoShapeRoundedRectangle, _
4, 4, 60, 20)
'Format Shape
shp.Fill.ForeColor.RGB = RGB(91, 155, 213) 'Blue
shp.Line.Visible = msoFalse
shp.TextFrame2.TextRange.Font.Size = 10
shp.TextFrame2.TextRange.Text = ContentName
shp.TextFrame2.TextRange.Font.Bold = True
shp.TextFrame2.TextRange.Font.Fill.ForeColor.RGB = RGB(255, 255, 255) 'White
'Track Shape Name with ID Tag
shp.Name = shp.Name & ButtonID
'Assign Hyperlink to Shape
sht.Hyperlinks.Add shp, "", _
SubAddress:="'" & ContentName & "'!A1"
End If
Next sht
End Sub
Last edited by a moderator: