Excel create TOC sheet

Option Explicit
Sub Create_TOC()
    Dim wbBook As Workbook
    Dim wsActive As Worksheet
    Dim wsSheet As Worksheet

    Dim lnRow As Long
    Dim lnPages As Long
    Dim lnCount As Long

    Set wbBook = ActiveWorkbook

    With Application
        .DisplayAlerts = False
        .ScreenUpdating = False
    End With


    On Error Resume Next
    With wbBook
        .Worksheets("TOC").Delete
        .Worksheets.Add Before:=.Worksheets(1)
    End With
    On Error GoTo 0

    Set wsActive = wbBook.ActiveSheet
    With wsActive
        .Name = "TOC"
        With .Range("A1:B1")
            .Value = VBA.Array("Table of Contents", "Sheet # – # of Pages")
            .Font.Bold = True
        End With
    End With

    lnRow = 2
    lnCount = 1


    For Each wsSheet In wbBook.Worksheets
        If wsSheet.Name <> wsActive.Name Then
            wsSheet.Activate
            With wsActive
                .Hyperlinks.Add .Cells(lnRow, 1), "", _
                SubAddress:="'" & wsSheet.Name & "'!A1", _
                TextToDisplay:=wsSheet.Name
                lnPages = wsSheet.PageSetup.Pages().Count
                .Cells(lnRow, 2).Value = "‘" & lnCount & " - " & lnPages
            End With
            lnRow = lnRow + 1
            lnCount = lnCount + 1
        End If
    Next wsSheet

    wsActive.Activate
    wsActive.Columns("A:B").EntireColumn.AutoFit

    With Application
        .DisplayAlerts = True
        .ScreenUpdating = True
    End With
End Sub