Table of contents with tabs with multiple pages not working all the time

[Zen8Master]

Pretty "Box Stock code" with change to what column it write to compared to original downloaded from microsoft
works sometimes often not
number of pages is wrong most often (200 -300 pages in total)
Help!
thanks
Zen


code---------

Sub BuildTOC()
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 GoTo 0
Set wsActive = wbBook.ActiveSheet
With wsActive
.Name = "Table of Contents"
With .Range("Z1:AA1")
.Value = VBA.Array("Table of Contents", "Sheet # - # of Pages")
.Font.Bold = True
End With
End With
lnRow = 2
lnCount = 1
'Iterate through the worksheets in the workbook and create
'sheetnames, add hyperlink and count & write the running number
'of pages to be printed for each sheet on the TOC sheet.
For Each wsSheet In wbBook.Worksheets
If wsSheet.Name <> wsActive.Name Then
wsSheet.Activate
With wsActive
.Hyperlinks.Add .Cells(lnRow, 26), "", SubAddress:="'" & wsSheet.Name & "'!A1", TextToDisplay:=wsSheet.Name
lnPages = wsSheet.PageSetup.Pages().Count
.Cells(lnRow, 27).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

Code -------