Adding A Page Break To A Specific and Dynamic Point in A Worksheet

A

Ark68

Well-known Member
Joined
Mar 23, 2004
Messages
4,570
Office Version
  1. 365
  2. 2016
Platform
  1. Windows
I am struggling with how to proceed with coding a particular challenge. Consider this code, which calculates the sum of the heights of all the rows (ptrh) in each of 11 particular worksheets of my workbook. The idea is to produce a document (a lined gridlike form basically) that fills an entire 8.5 x 11 printed page. I know the height of combined rows needed to do this equals 579.75pts. Subtracting the sub of the row heights already on the page (within the defined range) equals variable ptrh. The difference in the two is how much space remain on the 8.5 x 11 sheet that needs to be populated with rows. In my case, a default row height is 12.75. Dividing the remaining page by 12.75 gives us a rough idea how many rows to add to fill the page.

Code: 
Sub fill_pages()

    'fill pages (default height 643.5 pts)
        
    With wb_womain
        Dim dph As Double, cph As Double, markrow As Double, llrow As Double, diff As Double, rta As Double, a_pda As Double, a_fma As Double ', fmarow As Double
        Dim Q As Range, lrow_fma As Double, Ac As Range, add_apda As Double, add_afma As Double  'lrow_pda As Double,
        Dim ptrh As Double
        Dim va As Object, po As Integer, fmarow As Integer, lrow_pda As Integer
                                
        dph = 579.75
        
        arr4 = Array("Master", "CUE", "CUL", "HPE", "HPL", "RPE", "RPL", "CRP", "WPE", "WPL", "CWP")
        
        For po = 0 To UBound(arr4)
            Set va = Worksheets(arr4(po)) 'active worksheet
            ptrh = 0
            With va
                .Activate
                markrow = Application.WorksheetFunction.Match("mark", .Range("A1:A200"), 0)
                llrow = markrow + 4
                For Each Q In .Range("A1:A" & llrow)
                    ptrh = ptrh + Q.Height
                Next Q
                diff = dph - ptrh
                rta = WorksheetFunction.RoundDown((diff / 12.75), 0)
                
                'MsgBox "Default page height:   579.75 pts" & Chr(13) & "Current page height:   " & ptrh & " pts" & Chr(13) & "Difference:   " & diff & " pts" & Chr(13) & "Rows to add:   " & rta
                If rta > 0 Then
                    a_pda = WorksheetFunction.RoundDown((0.6 * rta), 0)
                    a_fma = rta - a_pda
                    fmarow = Application.WorksheetFunction.Match("Facility Maintenance Activities", .Range("A1:A200"), 0)
                    lrow_pda = fmarow - 3
                    Set Ac = ActiveSheet.Cells(lrow_pda, 1)
                    For add_apda = 1 To a_pda
                        Ac.offset(add_apda).EntireRow.Insert
                        
                    Next add_apda
                    .Range("H" & lrow_pda + 1 & ":Q" & lrow_pda + a_pda).Interior.ColorIndex = RGB(0, 0, 0)
                    With .Range("B" & lrow_pda + 1 & ":B" & lrow_pda + a_pda).Borders(xlInsideHorizontal)
                        .LineStyle = xlContinuous
                        .Weight = xlHairline
                        .ColorIndex = 1
                    End With
                    
                    fmarow = Application.WorksheetFunction.Match("mark", .Range("A1:A200"), 0)
                    lrow_fma = fmarow - 1
                    Set Ac = ActiveSheet.Cells(lrow_fma, 1)
                    For add_afma = 1 To a_fma
                        Ac.offset(add_afma).EntireRow.Insert
                    Next add_afma
                End If
                On Error Resume Next
                .Range("A" & lrow_fma + a_fma) = ""
                On Error GoTo 0
                gh1 = Application.WorksheetFunction.Match("mark", .Range("A:A"), 0)
                .Range("A" & gh1) = ""
            End With
            
        Next po
    
    End With
End Sub

I would like to now go one step further, but I have no idea how to do it with what I have so far.

If the sum of all the rows exceeds the max page allowance of 579.75 pts, I would like to insert a page break at this point. But, I need to complicate things a bit. The page break is to be before the last blank row available in the range that defines the max page allowance OR the row containing the value "Facility Maintenance Activities" in column A ... whichever comes first.

To me, this is an incredible challenge in not only figuring out how to do it, but to clearly explain it. I hope that the information I gave was adequate enough to give someone the info needed to help me tackle the issue.

I am unable to attach a sample to best illustrate the scenarios, so I will post a MrExcelHTML representation which poorly demonstrates the true perspective. (improper representation of row heights, unable to use colours to distinguish points of reference etc.)

Worksheet RPL1

Excel 2010
ABCDEFGHIJKLMNOPQ
120-Jun 8:10 PMTuesday June 20, 2017
2
3
4RPL1
52:00P - 10:00P
6
7
8Program Delivery ActivitiesDocument times completed
9TOURNAMENT RELINING
10Record IDDispatchRentalLocationActivityGroomPrepareSignatureLights OnLights Off1234Close
11
12
13429060147778612:00P5:00P
14429060167778612:00P5:00P
15429060187778612:00P5:00P
16429060217778612:00P5:00P
17429060237778612:00P5:00P
18429060257778612:00P5:00P
19
2042906019CHANGE <5:30P779076:00P8:00P
2142906015<6:00P778086:30P11:00P
2242906017778086:30P11:00P
2342906022778086:30P8:00P
2442906024778086:30P8:00P
2542906026778086:30P8:00P
2642906020CHANGE <8:00P789488:30P10:30P
27
2842906031776786:00P8:30P
2942906036776786:00P8:30P
3042906038777006:00P8:30P
3142906040777006:00P8:30P
3242906042777006:00P8:30P
3342906013782846:30P9:00P
3442906033777006:30P8:30P
3542906035776786:30P8:30P
3642906012785368:30P11:00P
3742906034780858:30P10:30P
3842906039780858:30P10:30P
3942906041780858:30P10:30P
4042906043780858:30P10:30P
41
42429060271944386:30P8:00P
43429060281944386:30P8:00P
44429060291944386:30P8:00P
45429060301944386:30P8:00P
46
47
48Facility Maintenance Activitiesdocument assigned and non-assigned maintenance activities
49
50W/OLocationActivity(Time)CompleteIncompleteInitials
51
522:30P-4:15P
53
54
55>5:00P
56>8:00P
57>9:45P
58
59
60
61Please use reverse for notes and comments
62
RPL1



The red line (row 45) indicates where Excel is automatically places the page break. The sum of all the rows 1:44 = 579.75 pts.
The green line (row 41) is the preferred location of the page break ... it's the last blank row is range rows 1:44.

Worksheet RPL2

Excel 2010
ABCDEFGHIJKLMNOPQ
120-Jun 8:10 PMTuesday June 20, 2017
2
3
4RPL1
52:00P - 10:00P
6
7
8Program Delivery ActivitiesDocument times completed
9TOURNAMENT RELINING
10Record IDDispatchRentalLocationActivityGroomPrepareSignatureLights OnLights Off1234Close
11
12
13429060147778612:00P5:00P
14429060167778612:00P5:00P
15429060187778612:00P5:00P
16429060217778612:00P5:00P
17429060237778612:00P5:00P
18429060257778612:00P5:00P
19
2042906019CHANGE <5:30P779076:00P8:00P
2142906015<6:00P778086:30P11:00P
2242906017778086:30P11:00P
2342906022778086:30P8:00P
2442906024778086:30P8:00P
2542906026778086:30P8:00P
2642906020CHANGE <8:00P789488:30P10:30P
27
2842906031776786:00P8:30P
2942906036776786:00P8:30P
3042906038777006:00P8:30P
3142906040777006:00P8:30P
3242906034780858:30P10:30P
3342906039780858:30P10:30P
3442906041780858:30P10:30P
3542906043780858:30P10:30P
36
37429060271944386:30P8:00P
38429060281944386:30P8:00P
39429060291944386:30P8:00P
40429060301944386:30P8:00P
41
42
43Facility Maintenance Activitiesdocument assigned and non-assigned maintenance activities
44
45W/OLocationActivity(Time)CompleteIncompleteInitials
46
472:30P-4:15P
48
49
50>5:00P
51>8:00P
52>9:45P
53
54
55
56Please use reverse for notes and comments
57
RPL2


The red line (row 46) indicates where Excel is automatically places the page break. The sum of all the rows 1:44 = 579.75 pts.
The green line (row 43) is the preferred location of the page break.

Special request ...
It would also be nice to be able to add 5 or 6 blank rows on the last page following any data in the Facility Maintenance Activity section providing it doesn't force a new page. This may be overextending my request for help, but if anyone is feeling a bit extra generous.
 

Excel Facts

Copy formula down without changing references
If you have =SUM(F2:F49) in F50; type Alt+' in F51 to copy =SUM(F2:F49) to F51, leaving the formula in edit mode. Change SUM to COUNT.
You must log in or register to reply here.

Similar threads

A
  • Question Question
Adding Borders To Cells Of Inserted Rows
Replies
0
Views
262
Ark68
A
D
  • Question Question
Help With Dynamically Adding Page Breaks to a Dynamic Worksheet for Printing
Replies
3
Views
640
Domenic
D
kelly mort
  • Question Question
Set page Break at a specific word
Replies
7
Views
841
kelly mort
kelly mort
A
  • Question Question
Adding Rows to Maximize Page Display
Replies
2
Views
360
Ark68
A

Forum statistics

Threads
1,223,911
Messages
6,175,324
Members
452,635
Latest member
laura12345

Share this page

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