CODEWITHSUNDEEP
excelvba
10101
10101

Reputation: 2402

Automatically insert page breaks in Page Break Preview

I have code for automatically inserting Page Breaks depending on sections in Column C.

My sections are in 4 rows.

enter image description here

Here is the code that used to work sometimes when sections were in Column B, now sections are in Column C and I have changed range but it does not seem to work:

Dim fnd As Range, r As Range, pb As Variant
Dim PrintVersion As Worksheet

Set PrintVersion = ThisWorkbook.Sheets("Print version")

PrintVersion.Activate

   ' make sure sheet is in page break view
    PrintVersion.Parent.Windows(1).View = xlPageBreakPreview

    ' first clear any set page breaks
    On Error Resume Next
    For Each pb In PrintVersion.HPageBreaks
        pb.Delete
    Next
    On Error GoTo 0

    ' move preposed breaks to top of segement
    With PrintVersion.HPageBreaks
        For pb = 1 To .Count
            Set r = Cells(.Item(pb).Location.Row, 3)
            Set fnd = Range("C:C").Find("*", r, , , , xlPrevious)
            If Not Intersect(fnd.Offset(, -1).Resize(fnd.Offset(, 1).End(xlDown).Row - fnd.Row + 1, 4), r) Is Nothing Then
                Set .Item(pb).Location = fnd
            DoEvents
        End If
        Next
    End With

Before that I have Wrapping and autofitting:

With PrintVersion.Range("Print_Area")

        With .Cells.Rows
            .WrapText = True
            .VerticalAlignment = xlCenter
            .EntireRow.AutoFit
        End With
End With

Result (page break should be on row 148):

enter image description here

Upvotes: 0

Views: 725

Answers (1)

Asger
Asger

Reputation: 3877

I suggest to reset all pagebreaks by ResetAllPageBreaks and to Find in the first column:

Private Sub BreakPages()
    Dim fnd As Range, r As Range, pb As Variant
    Dim PrintVersion As Worksheet

    Set PrintVersion = ThisWorkbook.Sheets("Print version")

    PrintVersion.Activate

    ' make sure sheet is in page break view
    PrintVersion.Parent.Windows(1).View = xlPageBreakPreview

    ' first clear any set page breaks
    PrintVersion.ResetAllPageBreaks

    ' move preposed breaks to top of segement
    With PrintVersion.HPageBreaks
        For pb = 1 To .Count
            ' check if first column is empty
            Set r = PrintVersion.Cells(.Item(pb).Location.Row, 1)
            If r.value = "" Then
                ' find previous cell in column 1 which is not empty
                Set fnd = PrintVersion.Columns(1).Find("*", r, , , , xlPrevious)
                ' set page break 1 row above it
                Set .Item(pb).Location = fnd.Offset(-1, 0)
                DoEvents
            End If
        Next
    End With
End Sub

Upvotes: 1

Related Questions