'==================================================================================================
' Create Simple Contents Page
' Tab number, hyperlinked tab name, visibility indicator
' Donna Graham 2025
'==================================================================================================

Option Explicit ' personal toolbox "contents" tab creator

Public Sub Create_Contents_Sheet()
    ' Runs against the workbook that is currently active
    CreateContentsSheet ActiveWorkbook, True   ' change to True if we want to include hidden sheets
End Sub

 
' Core routine
Private Sub CreateContentsSheet(ByVal wb As Workbook, Optional ByVal IncludeHidden As Boolean = False)
    Dim contentsName As String
    Dim toc As Worksheet
    Dim ws As Worksheet
    Dim r As Long
    
    If wb Is Nothing Then
        MsgBox "No active workbook detected.", vbExclamation
        Exit Sub
    End If
    
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual
    
    ' Find next available "Contents", "Contents2", "Contents3", ...
    contentsName = NextAvailableContentsName(wb, "Contents")
    
    ' Create the Contents sheet as the first sheet
    Set toc = wb.Worksheets.Add(Before:=wb.Worksheets(1))
    On Error Resume Next
    toc.name = contentsName
    If Err.Number <> 0 Then
        ' If a naming collision still happens for any reason, append a timestamp
        Err.Clear
        toc.name = contentsName & "_" & Format(Now, "yyyymmdd_hhnnss")
    End If
    On Error GoTo 0
    
    ' Headings
    With toc
        .Range("A4").Value = "No."
        .Range("B4").Value = "Sheet name"
        .Range("C4").Value = "Visibility"
        .Range("A4:C4").Font.Bold = True
    End With
    
    r = 5
    
    ' List sheets and add hyperlinks
    For Each ws In wb.Worksheets
        If ws.name <> toc.name Then
            If IncludeHidden Or ws.Visible = xlSheetVisible Then
                toc.Cells(r, 1).Value = r - 4
                toc.Cells(r, 2).Value = ws.name
                ' Make the name itself clickable (column B)
                AddSheetHyperlink toc.Cells(r, 2), ws.name, "A1"
                ' Also provide an explicit "Go" link in column C
                ' AddSheetHyperlink toc.Cells(r, 3), ws.Name, "A1", "Go"
                toc.Cells(r, 3).Value = SheetVisibilityText(ws)
                r = r + 1
            End If
        End If
    Next ws
    
    ' Tidy up formatting
    With toc
        .Columns("A:D").EntireColumn.AutoFit
        ' Freeze header row
        .Activate
        Range("A:D").HorizontalAlignment = xlCenter
        .Range("A5").Select
        ActiveWindow.FreezePanes = True
        .Range("A1").Select
        .Range("B2").Value = "Contents"
        .Range("B2").Font.Bold = True
        .Range("B2").Font.Color = RGB(255, 255, 255) 'change this to change colour of "Contents"
    
    'Add ColourBar Header
        With Range("A2:M2").Interior
            .Pattern = xlSolid
            .Color = RGB(0, 173, 233)  'change this to change the colour of the colourbar
        End With
    End With
    
    ActiveWindow.DisplayGridlines = False
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    
    MsgBox "Created '" & toc.name & "' with hyperlinks to each sheet.", vbInformation
End Sub
 
' Returns "Contents", "Contents2", "Contents3", ... the first that does not exist
Private Function NextAvailableContentsName(ByVal wb As Workbook, ByVal baseName As String) As String
    Dim n As Long
    Dim candidate As String
    
    candidate = baseName
    n = 1
    Do While SheetExists(wb, candidate)
        n = n + 1
        candidate = baseName & CStr(n)
    Loop
    
    NextAvailableContentsName = candidate
End Function
 
' Check if a sheet name exists
Private Function SheetExists(ByVal wb As Workbook, ByVal sheetName As String) As Boolean
    Dim s As Worksheet
    On Error Resume Next
    Set s = wb.Worksheets(sheetName)
    SheetExists = Not s Is Nothing
    Set s = Nothing
    On Error GoTo 0
End Function
 
' Add a hyperlink to a specific cell on a sheet within the same workbook
Private Sub AddSheetHyperlink(ByVal anchorCell As Range, ByVal targetSheetName As String, _
                              ByVal targetAddress As String, Optional ByVal textToDisplay As String = vbNullString)
    Dim subAddr As String
    subAddr = "'" & targetSheetName & "'!" & targetAddress
    If Len(textToDisplay) = 0 Then
        textToDisplay = targetSheetName
    End If
    
    ' Clear any existing hyperlink on the anchor cell first
    On Error Resume Next
    anchorCell.Hyperlinks.Delete
    On Error GoTo 0
    
    anchorCell.Parent.Hyperlinks.Add Anchor:=anchorCell, Address:="", SubAddress:=subAddr, _
                                     textToDisplay:=textToDisplay
End Sub
 
' Friendly visibility text for the listing
Private Function SheetVisibilityText(ByVal ws As Worksheet) As String
    Select Case ws.Visible
        Case xlSheetVisible:   SheetVisibilityText = "Visible"
        Case xlSheetHidden:    SheetVisibilityText = "Hidden"
        Case xlSheetVeryHidden: SheetVisibilityText = "VeryHidden"
        Case Else:             SheetVisibilityText = "Unknown"
    End Select
End Function