Onderstaand de gebruikte VBA code.
Sub Printen()
'
' Macro1 Macro
'
' Sneltoets: CTRL+P
'
Dim RW As Long
Dim TT As Long
Dim MSGtekst As String
Dim Bladnummer As Long
Dim Lastrow As Long
Dim Row_Index As Long
Dim Tabblad As Long
Dim Regels As Long
Dim TMregel As Long
Dim Aantalbreaks As Long
Dim Inhregel As Long
Dim Inhhoofdstuknr As Integer
Dim Inhhoofdstuknaam As String
Dim Inhbladnummer As Long
Dim Inh_regel As Long
Dim Inh_hoofdstuknr As Long
Dim Inh_hoofdstuknaam As String
'Dim Inh_bladnummer As String
Dim Lastrowinh As Long
Dim Lastrowtinh2 As String
'Keer geeft aan of het de eerste keer is (bepaling inhoudsopgave)
'of de tweede keer(afdrukken van het dossier)
Dim Keer As Long
'Initieren
Bladnummer = 1
Keer = 1
'Preview of Direct printen
MSGtekst = " Wilt u een preview?"
Response = MsgBox(MSGtekst, vbYesNoCancel, " VNEL")
If Response = vbCancel Then GoTo 150
'Inhousopgave leeg maken
For Tabblad = 2 To 3
Worksheets(Tabblad).Activate
With ActiveSheet
Lastrowinh = .Cells(Rows.Count, "c").End(xlUp).Row + Cells(5, 9)
End With
Lastrowtinh2 = Lastrowinh
bereik2 = "A3:G" + Lastrowtinh2
Range(bereik2).Select
Selection.Clear
Next
10 'For Tabblad = 4 To 14
For Tabblad = 4 To Worksheets.Count
'For Tabblad = 10 To 10
Worksheets(Tabblad).Activate
If Cells(4, 3) = "" And Keer = 1 Then GoTo 90
If Cells(4, 3) = "" Then GoTo 100
'Inhoudsopgave opgenomen hoofdstukken samenstellen
If Keer <> 1 Then GoTo 15
If Inhregel = 0 Then Inhregel = Cells(5, 9) + 1
Inhhoofdstuknr = Cells(1, 1)
Inhhoofdstuknaam = Cells(1, 2)
Inhbladnummer = Bladnummer
Worksheets(2).Activate
'Worksheets(2).Range("A3:K60").Font.FontStyle = "Verdana"
'
Cells(Inhregel, 1) = Inhhoofdstuknr
With Cells(Inhregel, 1)
.HorizontalAlignment = xlLeft
End With
Cells(Inhregel, 3) = Inhhoofdstuknaam
Cells(Inhregel, 7) = Inhbladnummer
Inhregel = Inhregel + 1
Worksheets(Tabblad).Activate
15 Worksheets(Tabblad).PageSetup.FirstPageNumber = Bladnummer
'Hoeveel regels tussen een page break (RW)
'RW bevat het aantal regels vanuit het actieve blad (I3)
'TT bevat het aantal titelregels (I5)
With ActiveSheet
RW = Cells(3, 9)
TT = Cells(5, 9)
Aantalbreaks = 1
'Remove all PageBreaks
.ResetAllPageBreaks
'Search for the last row with data in Column C
Lastrow = .Cells(Rows.Count, "C").End(xlUp).Row
'For Row_Index = RW + TT + 1 To Row_Index = RW + TT + 1 Step 1
' .HPageBreaks.Add Before:=.Cells(Row_Index, 1)
'Next
If Cells(6, 9) <> "" Then GoTo 25
For Row_Index = RW + TT + 1 To Lastrow Step RW
.HPageBreaks.Add Before:=.Cells(Row_Index, 1)
Aantalbreaks = Aantalbreaks + 1
Next
'End With
GoTo 50
25: Regels = TT + 1
TMregel = TT + 1
26: Regels = Regels + Cells(TMregel, 18)
TMregel = TMregel + Cells(TMregel, 18)
If Regels > Cells(3, 9) + 1 Then GoTo 30
If TMregel + 1 >= Lastrow Then GoTo 40
GoTo 26
30: TMregel = TMregel - Cells(TMregel - 1, 18)
Regels = Regels - Cells(Regels - 1, 18)
.HPageBreaks.Add Before:=.Cells(TMregel, 1)
If TMregel + Cells(TMregel - 1, 18) + 1 >= Lastrow Then Bladnummer = Bladnummer + 1: GoTo 50
Regels = TT + 1
Aantalbreaks = Aantalbreaks + 1
GoTo 26
40: End With
50: Bladnummer = Bladnummer + Aantalbreaks
If Keer = 1 Then GoTo 100
If Response = vbYes Then
ActiveSheet.PrintPreview
Else
ActiveSheet.PrintOut
End If
'If Keer = 2 And Aantalworksheets = Worksheets.Count Then GoTo 150
GoTo 100
90: 'Inhoudsopgave niet opgenomen hoofdstukken samenstellen
If Inh_regel = 0 Then Inh_regel = Cells(5, 9) + 1
Inh_hoofdstuknr = Cells(1, 1)
Inh_hoofdstuknaam = Cells(1, 2)
Worksheets(3).Activate
Cells(Inh_regel, 1) = Inh_hoofdstuknr
With Cells(Inh_regel, 1)
.HorizontalAlignment = xlLeft
End With
Cells(Inh_regel, 3) = Inh_hoofdstuknaam
Inh_regel = Inh_regel + 1
Worksheets(Tabblad).Activate
100:
Next
If Keer = 2 Then GoTo 150
If Keer = 1 Then Keer = 2
110: Bladnummer = 1
For Tabblad = 2 To 3
Worksheets(Tabblad).Activate
Worksheets(Tabblad).Range("A3:G60").Font.Name = "Verdana"
Worksheets(Tabblad).PageSetup.FirstPageNumber = Bladnummer
With ActiveSheet
RW = Cells(3, 9)
TT = Cells(5, 9)
Aantalbreaks = 1
.ResetAllPageBreaks
Lastrow = .Cells(Rows.Count, "A").End(xlUp).Row
For Row_Index = RW + TT + 1 To Lastrow Step RW
.HPageBreaks.Add Before:=.Cells(Row_Index, 1)
Aantalbreaks = Aantalbreaks + 1
Next
End With
Bladnummer = Bladnummer + Aantalbreaks
Next
Worksheets(2).Activate
With ActiveSheet
Lastrow = .Cells(Rows.Count, "A").End(xlUp).Row
For Row_Index = TT + 1 To Lastrow
Cells(Row_Index, 7) = Cells(Row_Index, 7) + 2
Next
End With
If Response = vbYes Then
ActiveSheet.PrintPreview
Worksheets(3).Activate
ActiveSheet.PrintPreview
Else
ActiveSheet.PrintOut
Worksheets(3).Activate
ActiveSheet.PrintOut
End If
GoTo 10
150:
End Sub
