Public Sub IndexSheetNames()

'       This subroutine requires two user functions:
'               WorksheetExtant
'               IsSheetNameValid
 
'       The subroutine will build an index sheet of all the sheetnames in the workbook

Dim xWs As Worksheet
On Error Resume Next

Application.DisplayAlerts = False

' First sort the sheets (if the user requires it)

Dim SortAnswer As Integer
SortAnswer = MsgBox("Do you want to sort the sheets first?", vbYesNo + vbQuestion, "Sort?")
If SortAnswer = vbYes Then
    Dim sCount, i, j As Integer
    sCount = Worksheets.Count
    If sCount = 1 Then Exit Sub
    For i = 1 To sCount - 1
        For j = i + 1 To sCount
            If Worksheets(j).name < Worksheets(i).name Then
                Worksheets(j).Move before:=Worksheets(i)
            End If
        Next j
    Next i
End If

Dim OurName As String
Dim Default As String
Dim GoodName As Boolean
Dim LastCol  As Integer
Dim LastRow As Integer
AskName:
GoodName = False
Default = "$$$INDEX"    ' <==== Change to your own default name
OurName = Default

' Comment out the code between the markers if you want to use only your default
' *****************************************************************************

Do Until GoodName = True
    OurName = InputBox("Name of Index sheet?" & vbCrLf _
        & vbCrLf & "(Null entry or Cancel will terminate)", "Enter Name For Index", Default:=Default)
    If OurName = "" Or OurName = vbNullString Then Exit Sub
    If Not IsSheetNameValid(OurName) Then
        Default = OurName
        MsgBox "Invalid sheet name" & vbCrLf & vbCrLf & "Please re-enter", vbCritical
    Else
        GoodName = True
    End If
Loop
' *****************************************************************************

XtitleId = OurName
If WorksheetExtant(XtitleId) Then
    SortAnswer = MsgBox("Do you want to overwrite the existing index?", vbYesNo + vbQuestion, "Overwrite?")
    If SortAnswer = vbNo Then
        If GoodName = False Then Exit Sub
        GoTo AskName
    End If
    Application.Sheets(XtitleId).Delete ' delete any existing sheet of our name
End If

Application.Sheets.Add Application.Sheets(1)

Set xWs = Application.ActiveSheet

xWs.name = XtitleId
xWs.Range("A1") = "Sheet Name"

' Add any other columns you may need in the index in here

xWs.Range("B1") = "Checked"                             ' *  These are the column headers.
xWs.Range("C1") = "Correct"                             ' *  Change these to match your own requirements
xWs.Range("D1") = "Comments                       "     ' *

LastCol = xWs.UsedRange.Columns(xWs.UsedRange.Columns.Count).Column

' Center headings, add borders and color the headings

xWs.Range("A1:D1").HorizontalAlignment = xlCenter
xWs.Range("A1:D1").Borders.LineStyle = xlContinuous
xWs.Range("A1:D1").Interior.ColorIndex = 15

X = Application.Sheets.Count
cal = 1
LastRow = Application.Sheets.Count + 1   '   Add one for the headers
For i = 2 To LastRow
   ' xWs.Range("A" & (i + 1)) = xWs.Application.Sheets(i).name
    With Sheets(OurName).Range("A" & i)
         If Not Application.Sheets(cal).Tab.Color = False Then .Interior.Color = xWs.Application.Sheets(cal).Tab.Color
         .Value = xWs.Application.Sheets(cal).name 'xWs.name
         cal = cal + 1
    End With
    'If Not xWs.Tab.Color = False Then .Interior.Color = xWs.Tab.Color
Next i

xWs.Range(Cells(1, 1), Cells(LastRow, LastCol)).Borders.LineStyle = xlContinuous
ActiveSheet.PageSetup.CenterHeader = "&C&24&U&B Index of Workbook " & ThisWorkbook.name
ActiveSheet.PageSetup.RightFooter = Format(Now, "MMMM DD, YYYY HH:MM:SS")
ActiveSheet.PageSetup.CenterFooter = "Page &P of &N"
ActiveSheet.PageSetup.CenterHorizontally = True
Application.DisplayAlerts = True
xWs.Range(Cells(1, 1), Cells(LastRow, LastCol)).EntireColumn.AutoFit
Range("A1").Select
Application.CutCopyMode = False
End Sub