Inhoudsopgave met paginanummers

[robinvdveeken]

Bijzondergewaardeerde forumleden,

Een vraag die ik vaker op internet ben tegengekomen maar waar ik nog geen passend antwoord op gevonden heb:

Door middel van hyperlinks is een index van de Worksheets maken een koud kunstje. Een inhoudsopgave, (index met paginanummers) is echter een stuk lastiger doordat Excel geen pagina's telt.
Ik heb nog even gedacht aan de nummering's mogelijkheid in de voettekst ( Page 3 van 147) Toch lijkt me dit ook niet toegankelijk.

Met behulp van wat andere bronnen op internet ben ik tot de volgende code gekomen:

Sub CreateTableOfContents()
       Dim WST As Worksheet
    On Error Resume Next
    Set WST = Worksheets("Table of Contents")
    If Not Err = 0 Then ' De Table of contents bestaat nog niet. Voeg deze toe.
        Set WST = Worksheets.Add(Before:=Worksheets(1))
        WST.Name = "TOC"
    End If
    On Error GoTo 0
    
    ' Maak nieuwe TOC pagina
    WST.[A2] = "Table of Contents"
    With WST.[A6]
        .CurrentRegion.Clear
        .Value = "Subject"
    End With
    WST.[B6] = "Page(s)"
    WST.Range("A1:B1").ColumnWidth = Array(36, 12)
    TOCRow = 7
    PageCount = 0
    ' Maak een printpreview
    ' sluit de preview handmatig
    Msg = "Excel moet een Printpreview doen om het aantal pagina's te bepalen. "
    Msg = Msg & "Sluit aub het previeuw venster door op Sluiten te klikken."
    MsgBox Msg
    ActiveWindow.SelectedSheets.PrintPreview
    ' Loop door elke sheet, verzameld informatie.
    For Each S In Worksheets
        If S.Visible = -1 Then
        S.Select
' Een van de drie onderstaande lijnen kan gebruikt worden om de titel te bepalen. De overige twee staan als commentaar geacceerd. 
        ThisName = ActiveSheet.Name
        'ThisName = Range("A1").Value
        'ThisName = ActiveSheet.PageSetup.LeftHeader
        HPages = ActiveSheet.HPageBreaks.Count + 1
        VPages = ActiveSheet.VPageBreaks.Count + 1
        ThisPages = HPages * VPages
        ' Vul de info in
        Sheets("TOC").Select
        Range("A" & TOCRow).Value = ThisName
        Range("B" & TOCRow).NumberFormat = "@"
        If ThisPages = 1 Then
            Range("B" & TOCRow).Value = PageCount + 1 & " "
        Else
            Range("B" & TOCRow).Value = PageCount + 1 & " - " & PageCount + ThisPages
        End If
        PageCount = PageCount + ThisPages
        TOCRow = TOCRow + 1
        End If
    Next S
End Sub

Hierbij word eerst een printscreen gemaakt zodat de pagina einden, zowel horizontaal als verticaal worden geteld. Deze met elkaar vermendigvuldigd geeft het aantal pagina's in een worksheet.
Toch werkt de code nog niet.

Iemand suggesties dan wel een andere code?
Alvast bedankt.

Groeten,
Robin

 

[E v R]

Je kunt middels een Excel4Macro de pagebreaks vinden, zie
_Hier_
Dan kun je vandaar uit weer verder

 

[robinvdveeken]

Bedankt voor je reactie.

De file waarvoor ik het wil gebruiken is zeer dynamisch.
Het komt erop neer dat deze niet alleen aan de achterzijde groeit maar er ook stukken tussen uit of ingevoegd worden. Een groot deel hiervan gebeurd door keuzes in een userform waardoor bepaalde delen verborgen kunnen worden.

Statische pagina einden blijven, zoals de naam als zegt dan op dezelfde positie (regel). Dit maakt een onoverzichtelijk (lelijk) document als deze word uitgeprint. Vandaar het idee om de pagebrakes die worden gegenereerd door de printpreview te gebruiken. Helaas kan de printpreview niet op de achtergrond worden uitgevoerd maar dit is overkomelijk.

Toch lijkt het me onwaarschijnlijk dat ik de eerste ben die een bestand op deelt in hoofdstukken, deze allen een eigen tabblad geeft en daar vervolgens een inhoudsopgave van wil maken.

Zijn er nog meer ideeën?

 

[E v R]

Printpreview lijkt mij overbodig;
Pas de code eens als volgt aan: (code kan nog wel wat efficienter)

Sub CreateTableOfContents()
    Dim WST    As Worksheet, TOCRow As Long, PageCount As Long, s As Worksheet
    Dim Thisname As String, HPages As Long, VPages As Long, ThisPages As Long
    On Error Resume Next
    Set WST = Worksheets("TOC")
    If Not Err = 0 Then    ' De Table of contents bestaat nog niet. Voeg deze toe.
        Set WST = Worksheets.Add(Before:=Worksheets(1))
        WST.Name = "TOC"
    End If
    On Error GoTo 0
    ' Maak nieuwe TOC pagina
    WST.[A2] = "Table of Contents"
    With WST.[A6]
        .CurrentRegion.Clear
        .Value = "Subject"
    End With
    WST.[B6] = "Page(s)"
    WST.Range("A1:B1").ColumnWidth = Array(36, 12)
    TOCRow = 7
    PageCount = 0
    ' Loop door elke sheet, verzameld informatie.
    For Each s In Worksheets
        If s.Visible = -1 Then
            ' Een van de drie onderstaande lijnen kan gebruikt worden om de titel te bepalen. De overige twee staan als commentaar geacceerd.
            Thisname = s.Name
            'ThisName = Range("A1").Value
            'ThisName = ActiveSheet.PageSetup.LeftHeader
            s.ResetAllPageBreaks
            HPages = s.HPageBreaks.Count + 1
            VPages = s.VPageBreaks.Count + 1
            ThisPages = HPages * VPages
            ' Vul de info in
            Sheets("TOC").Range("A" & TOCRow).Value = Thisname
            Sheets("TOC").Range("B" & TOCRow).NumberFormat = "@"
            If ThisPages = 1 Then
                Sheets("TOC").Range("B" & TOCRow).Value = PageCount + 1 & " "
            Else
                Sheets("TOC").Range("B" & TOCRow).Value = PageCount + 1 & " - " & PageCount + ThisPages
            End If
            PageCount = PageCount + ThisPages
            TOCRow = TOCRow + 1
        End If
    Next s
End Sub

 

[robinvdveeken]

Dit is hem uiteindelijk geworden:

Sub CreateTableOfContents()
    Dim WST    As Worksheet, TOCRow As Long, PageCount As Long, s As Worksheet
    Dim Thisname As String, HPages As Long, VPages As Long, ThisPages As Long
    On Error Resume Next
    Set WST = Worksheets("Table of contents")
    If Not Err = 0 Then    ' De Table of contents bestaat nog niet. Voeg deze toe.
        Set WST = Worksheets.Add(Before:=Worksheets(1))
        WST.Name = "Table of contents"
    End If
    On Error GoTo 0
    ' Maak nieuwe TOC pagina
    WST.[A2] = "Table of Contents"
    With WST.[A6]
        .CurrentRegion.Clear
        .Value = "Subject"
    End With
    WST.[B6] = "Page(s)"
    WST.Range("A1:B1").ColumnWidth = Array(36, 12)
    TOCRow = 7
    PageCount = 0
    ' Loop door elke sheet, verzameld informatie.
    For Each s In Worksheets
        If s.Visible = -1 Then
            ' Een van de drie onderstaande lijnen kan gebruikt worden om de titel te bepalen. De overige twee staan als commentaar geacceerd.
            Thisname = s.Name
            'ThisName = Range("A1").Value
            'ThisName = ActiveSheet.PageSetup.LeftHeader
            s.ResetAllPageBreaks
            HPages = s.HPageBreaks.Count + 1
            VPages = s.VPageBreaks.Count + 1
            ThisPages = HPages * VPages
            ' Vul de info in
            Sheets("Table of contents").Range("A" & TOCRow).Value = Thisname
            Sheets("Table of contents").Range("B" & TOCRow).NumberFormat = "@"
            If ThisPages = 1 Then
                Sheets("Table of contents").Range("B" & TOCRow).Value = PageCount + 1 & " "
            Else
                Sheets("Table of contents").Range("B" & TOCRow).Value = PageCount + 1 & " - " & PageCount + ThisPages
            End If
            PageCount = PageCount + ThisPages
            TOCRow = TOCRow + 1
        End If
    Next s
End Sub