Inserting Page Breaks with Macro

rein26

New Member
Joined
Feb 12, 2016
Messages
12
Hi and thank you for looking,

I'm trying to create a macro to insert page breaks above each Header row (Row 1,7,11 in this ex) and if the data between each header contains more than 3 rows, insert a page break every 3 rows. So, below the macro would place a page break between row 4&5, 6&7, 10&11.

This data is Dynamic and the amount of rows between each header varies from file to file.

I've tried to record the macro and create code with no luck. I know there will most likely be a loop and rely on the



[TABLE="width: 500"]
<tbody>[TR]
[TD][/TD]
[TD]A[/TD]
[TD]B[/TD]
[TD]C[/TD]
[TD]D[/TD]
[TD]E[/TD]
[TD]F[/TD]
[TD]G[/TD]
[TD]H[/TD]
[TD]I[/TD]
[TD]J[/TD]
[/TR]
[TR]
[TD]1[/TD]
[TD]Header Text[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD]x[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]2[/TD]
[TD]x[/TD]
[TD]x[/TD]
[TD]x[/TD]
[TD]x[/TD]
[TD]x[/TD]
[TD]x[/TD]
[TD]x[/TD]
[TD]x[/TD]
[TD]x[/TD]
[TD]x[/TD]
[/TR]
[TR]
[TD]3[/TD]
[TD]x[/TD]
[TD]x[/TD]
[TD]x[/TD]
[TD]x[/TD]
[TD]x[/TD]
[TD]x[/TD]
[TD]x[/TD]
[TD]x[/TD]
[TD]x[/TD]
[TD]x[/TD]
[/TR]
[TR]
[TD]4[/TD]
[TD]x[/TD]
[TD]x[/TD]
[TD]x[/TD]
[TD]x[/TD]
[TD]x[/TD]
[TD]x[/TD]
[TD]x[/TD]
[TD]x[/TD]
[TD]x[/TD]
[TD]x[/TD]
[/TR]
[TR]
[TD]5[/TD]
[TD]x[/TD]
[TD]x[/TD]
[TD]x[/TD]
[TD]x[/TD]
[TD]x[/TD]
[TD]x[/TD]
[TD]x[/TD]
[TD]x[/TD]
[TD]x[/TD]
[TD]x[/TD]
[/TR]
[TR]
[TD]6[/TD]
[TD]x[/TD]
[TD]x[/TD]
[TD]x[/TD]
[TD]x[/TD]
[TD]x[/TD]
[TD]x[/TD]
[TD]x[/TD]
[TD]x[/TD]
[TD]x[/TD]
[TD]x[/TD]
[/TR]
[TR]
[TD]7[/TD]
[TD]Header Text[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD]x[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]8[/TD]
[TD]x[/TD]
[TD]x[/TD]
[TD]x[/TD]
[TD]x[/TD]
[TD]x[/TD]
[TD]x[/TD]
[TD]x[/TD]
[TD]x[/TD]
[TD]x[/TD]
[TD]x[/TD]
[/TR]
[TR]
[TD]9[/TD]
[TD]x[/TD]
[TD]x[/TD]
[TD]x[/TD]
[TD]x[/TD]
[TD]x[/TD]
[TD]x[/TD]
[TD]x[/TD]
[TD]x[/TD]
[TD]x[/TD]
[TD]x[/TD]
[/TR]
[TR]
[TD]10[/TD]
[TD]x[/TD]
[TD]x[/TD]
[TD]x[/TD]
[TD]x[/TD]
[TD]x[/TD]
[TD]x[/TD]
[TD]x[/TD]
[TD]x[/TD]
[TD]x[/TD]
[TD]x[/TD]
[/TR]
[TR]
[TD]11[/TD]
[TD]Header Text[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]
 
Yikes,

Use this instead:

Code:
Sub InstPgBrk()


    Dim blnk As Range, LastCell As Range
    Dim lRow As Long, i As Long, brkrow As Long
    Dim blkBs As Long, PgBrkNo As Long, E3R As Long
    
    ActiveSheet.ResetAllPageBreaks
    Set LastCell = Cells(Cells.Find(What:="*", SearchOrder:=xlRows, _
                SearchDirection:=xlPrevious, LookIn:=xlFormulas).Row, _
                Cells.Find(What:="*", SearchOrder:=xlByColumns, _
                SearchDirection:=xlPrevious, LookIn:=xlFormulas).Column)
    lRow = LastCell.Row
    blkBs = WorksheetFunction.CountBlank(Range("B2:B" & lRow))
    
''''''''''''''''''''''''''''''''''''''''Do Every 3 rows''''''''''''''''''''''''''''''''''
    Set blnk = Range("B2:B" & lRow).Find(What:="", _
                LookIn:=xlValues, _
                LookAt:=xlWhole, _
                SearchOrder:=xlByRows, _
                SearchDirection:=xlNext, _
                MatchCase:=False)
    brkrow = blnk.Row
    
    E3R = 2
oneBlank:
    Do Until E3R >= lRow
        If Range("B" & E3R).Value = "" Then
            E3R = E3R + 1
            GoTo oneBlank
        End If
        If Range("B" & E3R).Value <> "" Then
            If Range("B" & E3R + 1).Value <> "" Then
                If Range("B" & E3R + 2).Value <> "" Then
                    ActiveSheet.HPageBreaks.Add before:=Range("B" & E3R + 3)
                End If
            End If
        End If
        E3R = Range("B" & E3R + 3).Row
    Loop
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''Do Header Rows'''''''''''''''''''''''''''''''''''''
    
    Set blnk = Range("B2:B" & lRow).Find(What:="", _
                LookIn:=xlValues, _
                LookAt:=xlWhole, _
                SearchOrder:=xlByRows, _
                SearchDirection:=xlNext, _
                MatchCase:=False)
    brkrow = blnk.Row


    ActiveSheet.HPageBreaks.Add before:=Cells(brkrow, 2)
    PgBrkNo = PgBrkNo + 1
    
    Do Until PgBrkNo >= blkBs
DblHdr:
        Set blnk = Range("B" & brkrow & ":B" & lRow).Find(What:="", _
                    LookIn:=xlValues, _
                    LookAt:=xlWhole, _
                    SearchOrder:=xlByRows, _
                    SearchDirection:=xlNext, _
                    MatchCase:=False)
        If blnk Is Nothing Then GoTo LH
        If brkrow + 1 = blnk.Row Then
            brkrow = brkrow + 2
            GoTo DblHdr
        End If
        brkrow = blnk.Row
        ActiveSheet.HPageBreaks.Add before:=Cells(brkrow, 2)
        PgBrkNo = PgBrkNo + 1
    Loop
LH:
   
End Sub
Sorry about the confusion...

igold
 
Upvote 0
Thank you. I tried to run it and received this error about 10 lines up from the bottom of the code:


Compile Error: Label not defined


If blnk Is Nothing Then GoTo ThreeRows
 
Upvote 0
I know, that is why I posted the second copy. Make sure you are using the post # 11.
 
Upvote 0
Works perfectly! Thank you!

For fun, this is what I came up with to at least get the pagebreaks above the headers. It works, but an it takes forever to run and get an overflow error...it was fun trying though!

Dim i As Integer
i = 2

Do Until i = Cells(i, 1) = ""
If Cells(i, 2).Value = "" And Cells(i, 1).Value <> "" Then
Cells(i, 1).PageBreak = xlPageBreakManual
End If


i = i + 1

Loop
 
Upvote 0
Great, I am glad that it works for you.

I find that one of the great things about Excel is that you can do any particular task in multiple ways. I am sure that if you took the time you could create a line in your code that would suppress the overflow error or redirect the code before the error pops.

Thanks for the feedback!

Regards,

igold
 
Upvote 0
By studying your code I was able to use some technique/logic and fix my overflow issue (Establishing FinalRow for more efficient, smaller data set). Too bad I can't use this code since your's is way better :)

Thanks again, you really helped me advance my VBA knowledge!

ActiveSheet.ResetAllPageBreaks
FinalRow = Cells(Rows.Count, 1).End(xlUp).Row

Dim i As Integer
i = 2

Do Until i = FinalRow
If Cells(i, 2).Value = "" And Cells(i, 1).Value <> "" Then
Cells(i, 1).PageBreak = xlPageBreakManual
End If

i = i + 1
Loop
 
Upvote 0
Again, thanks for the feedback. I am completely self taught and learning new stuff everyday. It is one of the reasons why I like this site the best.

It was my pleasure to help you get better at VBA. There are some really great coders on this site and more often than not they want to help others learn. I am a novice compared to a lot of the guys and gals on here.

But I try!!
 
Upvote 0

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top