Table of Content: Count all pages per TAB, continue on next TAB with page number

[Unicode]

I have a workbook with 40 sheets, I have created query that should provide a Table of Content. What I need is the query to provide the page in sequence with the next TAB providing the next PAGE number, "not the total amount of pages". In other words, if my Executive summary has 3 pages in total, and, my next TAB named "Balance Sheet" only has one page, I will need to see the next page as page four. Example: Executive summary has 3 pages on workbook sheet, I select the next TAB called, "Balance sheet", this sheet only has 2 pages on the sheet, so, I should see on my table of content page 4, and if the next TAB is "Income Statement" TAB sheet, and only has 4 pages, then this section should say PAGE 6 in the Table of Content. Also, I tried to remove hyperlinks, however, if I remove script code hyperlink, script stops running.



The following is my attempt at the macro. I do not have much suitable test data but it appears to work.

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


Application.ScreenUpdating = False  'Makes the code run faster and reduces screen _
    flicker a bit.


Set wbBook = ActiveWorkbook


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


'If the TOC sheet already exist delete it and add a new
'worksheet.


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


Set wsActive = wbBook.ActiveSheet
With wsActive
    .Name = "TOC"
    With .Range("B4:C4", "F4")
       .Value = VBA.Array("", "", "", , "")
        .Font.Bold = True
        .Font.Size = 22
        .Font.Name = "Calibri"


    End With
    
With Worksheets("TOC").Range("B2:B2")
 .Value = "Section"
 .Font.Size = 22
 .Font.Name = "Calibri"
End With
    
With Worksheets("TOC").Range("B4:B4")
 .Value = "Section"
 .Font.Size = 11
 .Font.Name = "Calibri"
End With


With Worksheets("TOC").Range("F4:F4")
 .Value = "Page"
 .Font.Size = 11
 .Font.Name = "Calibri"
End With


With Worksheets("TOC").Range("A17:A17")
 .Value = "Notes:"
 .Font.Size = 11
 .Font.Name = "Calibri"
End With




Worksheets("TOC").Range("A17:A17").Font.Bold = True
Worksheets("TOC").Range("A17:A17").Font.Italic = True
Worksheets("TOC").Range("B4:B4").Font.Italic = True
Worksheets("TOC").Range("F4:F4").Font.Italic = True
Worksheets("TOC").Range("B2:B2").Font.Bold = True


Dim i As Integer


i = ActiveCell.Row + 1


Excel.ActiveSheet.Cells(i, 2).Value = "Table of Contents"








lnRow = 5
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, 3), "", _
            SubAddress:="‘" & wsSheet.Name & "'!B1", _
            TextToDisplay:=wsSheet.Name
            lnPages = wsSheet.PageSetup.Pages().Count
            .Cells(lnRow, 2).Value = "" & lnCount
              .Cells(lnRow, 6).Value = "" & lnPages
        End With
        lnRow = lnRow + 1
        lnCount = lnCount + 1
    End If
Next wsSheet


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


With Application
    .DisplayAlerts = True
    .ScreenUpdating = True


End With
End With


End Sub

 

[Unicode]

Found the Hyperlink removal code listed below. ActiveSheet.Hyperlinks.Delete