Creating a ToC

Sub TableOfContents_Create()
'PURPOSE: Add a Table of Contents worksheets to easily navigate to any tab

Dim sht As Worksheet
Dim Content_sht As Worksheet
Dim myArray As Variant
Dim x As Long, y As Long
Dim shtName1 As String, shtName2 As String
Dim ContentName As String

'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

'Create New Contents Sheet
  Worksheets.Add Before:=Worksheets(1)

'Set variable to Contents Sheet
  Set Content_sht = ActiveSheet

'Format Contents Sheet
  With Content_sht
    .Name = ContentName
    .Range("B1") = "Table of Contents"
    .Range("B1").Font.Bold = True
  End With

'Create Array list with sheet names (excluding Contents)
  ReDim myArray(1 To Worksheets.Count - 1)

  For Each sht In ActiveWorkbook.Worksheets
    If sht.Name <> ContentName 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
  For x = LBound(myArray) To UBound(myArray)
    Set sht = Worksheets(myArray(x))
    sht.Activate
    With Content_sht
      .Hyperlinks.Add .Cells(x + 2, 3), "", _
      SubAddress:="'" & sht.Name & "'!A1", _
      TextToDisplay:=sht.Name
      .Cells(x + 2, 2).Value = x
    End With
  Next x
  
Content_sht.Activate
Content_sht.Columns(3).EntireColumn.AutoFit

'A Splash of Guru Formatting! [Optional]
  Columns("A:B").ColumnWidth = 3.86
  Range("B1").Font.Size = 18
  Range("B1:F1").Borders(xlEdgeBottom).Weight = xlThin
  
  With Range("B3:B" & x + 1)
    .Borders(xlInsideHorizontal).Color = RGB(255, 255, 255)
    .Borders(xlInsideHorizontal).Weight = xlMedium
    .HorizontalAlignment = xlCenter
    .VerticalAlignment = xlCenter
    .Font.Color = RGB(255, 255, 255)
    .Interior.Color = RGB(91, 155, 213)
  End With

  'Adjust Zoom and Remove Gridlines
    ActiveWindow.DisplayGridlines = False
    ActiveWindow.Zoom = 100

ExitSub:
'Optimize Code
  Application.DisplayAlerts = True
  Application.ScreenUpdating = True
  
End Sub

Sub TableOfContents_Create2()
'PURPOSE: Add a Table of Contents worksheets to easily navigate to any tab (multiple columns)

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 2"

'Optimize Code
  Application.DisplayAlerts = False
  Application.ScreenUpdating = False

'Delete Contents Sheet if it already exists
  On Error Resume Next
    Worksheets("Contents 2").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

Sub Contents_Hyperlinks()
'PURPOSE: Add hyperlinked buttons back to Table of Contents worksheet tab

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

Sub createIndex1()
'Create An index sheet with Hyperlinks
Dim ws As Worksheet, i As Integer
Worksheets.Add(Before:=Worksheets(1)).Name = "Index"
For Each ws In ThisWorkbook.Worksheets
If ws.Name <> "Index" Then
i = i + 1
Sheets("Index").Range("A" & i).Value = ws.Name
Sheets("Index").Hyperlinks.Add Anchor:=Range("A" & i), Address:="", SubAddress:="'" & ws.Name & "'!A1", TextToDisplay:=ws.Name
End If
Next ws
Sheets("Index").Columns("A").AutoFit
'Add 2 rows
Rows("1:2").Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
End Sub