Vba excel разрывы страниц

As part of an overhaul of a report generator I saw what I believed to be inefficient code. This part of the code runs after the main report is generated to set the page breaks in logical positions. The criteria is this:

• Each Site starts on a new page.
• Group’s aren’t allowed to broken across pages.

The code follows the above format: 2 loops doing those jobs.

This is the original code (sorry for the length):

Public Sub PageBreak(ByRef wstWorksheet As Excel.Worksheet, ByVal pctProgress As ProgressCtl.ProgressControl)
Dim breaksMoved As Integer
Dim p As HPageBreak
Dim i As Integer

'Used as a control value
breaksMoved = 1

' Marks that no rows/columns are to be repeated on each page
wstWorksheet.Activate
wstWorksheet.PageSetup.PrintTitleRows = ""
wstWorksheet.PageSetup.PrintTitleColumns = ""

'If this isn't performed beforehand, then the HPageBreaks object isn't available
Range("A3").Select
ActiveWindow.View = xlPageBreakPreview

'Defaults the print area to be the entire sheet
wstWorksheet.DisplayPageBreaks = False
wstWorksheet.PageSetup.PrintArea = ""

Range("$B$4").Select

' add breaks after each site
Do While ActiveCell.Row <= wstWorksheet.UsedRange.Rows.Count
    If ActiveCell.FormulaR1C1 = "Site ID" Then
        ActiveCell.PageBreak = xlPageBreakManual
    End If
    ActiveCell.Offset(1, 0).Activate
    pctProgress.ProgressText = "Row " & CStr(ActiveCell.Row) & " of " & CStr(wstWorksheet.UsedRange.Rows.Count)
Loop

Dim passes As Long
Do While breaksMoved = 1
    passes = passes + 1
    breaksMoved = 0
    For i = 1 To wstWorksheet.HPageBreaks.Count - 1
            Set p = wstWorksheet.HPageBreaks.Item(i)
            'Selects the first page break
            Range(p.Location.Address).Select
            'Sets the ActiveCell to 1 row above the page break
            ActiveCell.Offset(-1, 0).Activate

            'Move the intended break point up to the first blank section
            Do While Not ActiveCell.FormulaR1C1 = ""
                ActiveCell.Offset(-1, 0).Activate
                breaksMoved = 1
            Loop

            'Add the page break
            If ActiveCell.FormulaR1C1 <> "Site ID" Then
                ActiveCell.Offset(1, 0).Activate
                wstWorksheet.HPageBreaks.Add ActiveCell
            End If

            pctProgress.ProgressText = "Set break point " & CStr(passes) & "." & CStr(i)

    Next

Loop

'Reset the view to normal
wstWorksheet.DisplayPageBreaks = True
ActiveWindow.View = xlNormalView
Range("A3").Select
End Sub

Seeing room for improvement I set about modifying this. As one of the new requirements the people wanting the report were manually removing pages prior to printing. So I added checkboxes on another page and copied the checked items across. To ease that I used named ranges. I used these named ranges to meet the first requirement:

' add breaks after each site   
For Each RangeName In ActiveWorkbook.Names
    If Mid(RangeName.Name, 1, 1) = "P" Then
        Range(RangeName).Activate
        ActiveCell.Offset(Range(RangeName).Rows.Count - 1, 0).Select
        ActiveCell.PageBreak = xlPageBreakManual
    End If
Next RangeName

All Ranges are prefixed with P_ (for parent). Using the lame Now() style of rough timing this is 1 second slower on my short 4 site report and the more challenging 15 site report. These have 606 and 1600 rows respectively.

1 second isn’t so bad. Lets look at the next criteria.
Each logical group is split by a blank row, so the easiest way is to find the next page break, step back until you find the next blank line and insert the new break. Rinse and repeat.

So why does the original run through multiple times? We can improve that too (the boiler plate outside the loops is the same).

Dim i As Long
Dim oPageBreak As HPageBreak
Do While i < shtDeliveryVariance.HPageBreaks.Count - 1
    i = i + 1
    pctProgress.ProgressText = "Setting Page Break " & CStr(i) & " of " & CStr(shtDeliveryVariance.HPageBreaks.Count)

    Set oPageBreak = shtDeliveryVariance.HPageBreaks.Item(i)

    ' select the page break
    Range(oPageBreak.Location.Address).Select
    ActiveCell.Offset(-1, 0).Activate

    ' move up to a free row
    Do While Not ActiveCell.FormulaR1C1 = ""
        ActiveCell.Offset(-1, 0).Activate
    Loop

    'Add the page break
    If ActiveCell.FormulaR1C1 <> "Site ID" Then
        ActiveCell.Offset(1, 0).Activate
        shtDeliveryVariance.HPageBreaks.Add ActiveCell
    End If

Loop

One pass and more elegant too. But how much quicker is it? On the small test is takes 54 seconds compared to the original 45 seconds, and on the larger test my code is slower again at 153 to 130 seconds. And this is averaged over 3 runs too.

So my questions are: Why is my newer code so much slower than the original despite mine looking faster and what can I do to speed up the slowness of the code?

Note: Screen.Updating, etc. is already off as is Calculation etc.

1

ActiveDocument.ActiveWindow.Panes(1).Pages

1

ActiveDocument.ActiveWindow.Panes(1).Pages(1).Rectangles(1).Range.Text

1

ActiveSheet.HPageBreaks

1

ActiveSheet.VPageBreaks

1
2
3
4
5

Sub GetPrintPagesCount1()
   Dim intPagesCount As Integer
   intPagesCount = ActiveSheet.HPageBreaks.Count + 1
   MsgBox "Количество страниц по вертикали: " & intPagesCount
End Sub

1
2
3
4
5

Sub GetPrintPagesCount1()
   Dim intPagesCount As Integer
   intPagesCount = ActiveSheet.VPageBreaks.Count + 1
   MsgBox "Количество страниц по горизонтали: " & intPagesCount
End Sub

1
2
3
4
5
6
7
8
9

Sub GetPrintPagesCount1()
    Dim intPagesCount As Integer
    intPagesCount = ActiveSheet.VPageBreaks.Count + 1
    If intPagesCount > 1 Then
        MsgBox "Файл не умещается в ширину на страницу. Количество страниц по горизонтали: " & intPagesCount
    Else
        MsgBox "Файл умещается в ширину на страницу. Количество страниц по горизонтали: 1"
    End If
End Sub

1
2
3
4
5
6

Sub GetPrintPagesCount1()
   Dim intPagesCount As Integer
   intPagesCount = (ActiveSheet.HPageBreaks.Count + 1) * _
       (ActiveSheet.VPageBreaks.Count + 1)
   MsgBox "Всего страниц: " & intPagesCount
End Sub

1
2
3

Sub pages01()
    MsgBox Worksheets(1).PageSetup.Pages.Count
End Sub

1
2
3
4
5
6
7
8
9
10
11

Sub GetPrintPagesCount()
   Dim wshtSheet As Worksheet
   Dim intPagesCount As Integer
   ' Суммирование количества страниц, необходимых для печати всех _
    листов книги
   For Each wshtSheet In Worksheets
      intPagesCount = intPagesCount + (wshtSheet.HPageBreaks.Count + 1) * _
       (wshtSheet.VPageBreaks.Count + 1)
   Next
   MsgBox "Всего страниц: " & intPagesCount
End Sub

1
2
3
4

Sub HPageBreaksAdd1()
    ' Вставить разрыв страницы
    ActiveWindow.SelectedSheets.HPageBreaks.Add Before:=ActiveCell
End Sub

1
2
3
4
5

Sub HPageBreaksDel1()
' Удалить разрыв страницы
    ActiveSheet.HPageBreaks(4).Delete
    ' 4 - это порядковый номер удаляемого пользовательского разрыва страницы
End Sub

1
2
3
4
5
6
7
8

Sub HPageBreaksDel2()
    Dim i As Integer
    For i = 1 To ActiveSheet.HPageBreaks.Count
        If ActiveSheet.HPageBreaks(i).Location.Row = ActiveCell.Row Then
            ActiveSheet.HPageBreaks(i).Delete
        End If
    Next
End Sub

1
2
3

Private Sub Workbook_BeforePrint(Cancel As Boolean)
    Sheets("Sheet1").PrintOut From:=1, To:=1
End Sub

Всего комментариев

This is completely brilliant — thank you!

For those who might be interested in creating VERTICAL page breaks — eg for each year in a cash flow — I share my code as below:

Sub pagebreaks()
'insert the required page breaks automatically
' see https://stackoverflow.com/questions/51632995/inserting-page-break-with-vba

    Dim ws As Worksheet
    Dim overallendcol As Long
    Dim mycol As Long
    
'set the working sheet
    Set ws = Sheets("cf mthly")

'clear existing page breaks
    ActiveWindow.View = xlNormalView
    ActiveSheet.Cells.pagebreak = xlPageBreakNone

'establish the first new year column
    Cells(1, 1).Select
    Cells.Find(What:="Jan", After:=ActiveCell, LookIn:= _
        xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:= _
        xlNext, MatchCase:=False, SearchFormat:=False).Activate
    newyearcol = ActiveCell.Column

'establish the overall last column
    Cells(1, 1).Select
    Cells.Find(What:="totals", After:=ActiveCell, LookIn:= _
        xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:= _
        xlNext, MatchCase:=False, SearchFormat:=False).Activate
    overallendcol = ActiveCell.Column

'establish each new year column
    Cells(1, 1).Select
    For mycol = newyearcol To overallendcol - 1 Step 12
        ws.Columns(newyearcol).pagebreak = xlPageBreakManual
    Next mycol

End Sub