Sub CreateTOC()
Dim wsA As Worksheet
Dim ws As Worksheet
Dim wsTOC As Worksheet
Dim lRow As Long
Dim rngList As Range
Dim lCalc As Long
Dim strTOC As String
Dim strCell As String
lCalc = Application.Calculation

On Error GoTo errHandler
Application.EnableEvents = False
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

strTOC = "TOC"
strCell = "A1"
Set wsA = ActiveSheet

On Error Resume Next
Set wsTOC = Sheets(strTOC)
On Error GoTo errHandler

If wsTOC Is Nothing Then
  Set wsTOC = Sheets.Add(Before:=Sheets(1))
  wsTOC.Name = strTOC
Else
  wsTOC.Cells.Clear
End If

With wsTOC
  .Range("B1").Value = "Sheet Name"
  lRow = 2
  For Each ws In ActiveWorkbook.Worksheets
    If ws.Visible = xlSheetVisible _
          And ws.Name <> strTOC Then
      .Cells(lRow, 2).Value = ws.Name
      .Hyperlinks.Add _
          Anchor:=.Cells(lRow, 2), _
          Address:="", _
          SubAddress:="'" & ws.Name _
            & "'!" & strCell, _
          ScreenTip:=ws.Name, _
          TextToDisplay:=ws.Name
      lRow = lRow + 1
    End If
  Next ws
  
  Set rngList = .Cells(1, 2).CurrentRegion
  rngList.EntireColumn.AutoFit
  .Rows(1).Font.Bold = True
End With

Application.ScreenUpdating = True
wsTOC.Activate
wsTOC.Cells(1, 2).Activate

exitHandler:
  Application.EnableEvents = True
  Application.ScreenUpdating = True
  Application.Calculation = lCalc
  Set rngList = Nothing
  Set wsTOC = Nothing
  Set ws = Nothing
  Set wsA = Nothing
  Exit Sub
errHandler:
  MsgBox "Could not create list"
  Resume exitHandler
End Sub