Insert Page Breaks and Adjust Rows XL2003

SonGunnar

New Member
Joined
Jul 20, 2008
Messages
5
Problems:
Groups of data should not split at inserted page breaks.
Row heights vary at the 3rd and 5th row of each 7 row group.
Typical pages have between 4 and 6 groups.
Average projects contain 10 - 50 pages, or 40 - 250 groups.
What I am trying to do is adjust the height of every 5th and 7th blank rows of each group on each page to fill the available paper space (78 points x 9" = 702 points).
Macro:
Sub DpageBreaks()
' points per inch times inches 78 points x 9 inches
Const sngH As Single = 78# * 9#
' lines of scope to keep together equal to 1 estimate scope item, j
Const iGroup As Integer = 7
Dim i As Long, j As Long
Dim rPA As Range
ActiveSheet.ResetAllPageBreaks
Set rPA = Range("Print_Area")
i = 4
j = i + iGroup - 1
Do
Do
If Range(rPA(i, 1), rPA(j, 1)).Height > sngH Then
ActiveSheet.HPageBreaks.Add before:=Rows(j - iGroup + 1)
Exit Do
Else
j = j + iGroup
End If
Loop While j < rPA.Rows.Count
i = j - iGroup + 1
j = i + iGroup - 1
Loop While i < rPA.Rows.Count
End Sub
Your help is truly appreciated :biggrin:
 

Some videos you may like

Excel Facts

Can Excel fill bagel flavors?
You can teach Excel a new custom list. Type the list in cells, File, Options, Advanced, Edit Custom Lists, Import, OK

SonGunnar

New Member
Joined
Jul 20, 2008
Messages
5
Well,

While thinking of something else, the solution wormed it's way into the conscious part of my grey matter, and so I post the answer here, in case someone else needs to do the same thing. Not sure of the rules about this but I can post the results on a personal web page, or shared windows skydrive account if anyone needs it. Working Code is as follows:

Sub AdjustRows()
Dim fourGrpPg, fiveGrpPg As Long
'Const pgH As Single = ppi * InchsPrntd
'Const rowGrp As Integer
Dim pgH, rowGrp As Integer
Dim ppi, InchsPrntd As Integer
Dim pbRowBgn, pbRowEnd As Long
pbRowBgn = InputBox("Enter Number of Rows " & CrLf & _
"That Repeat at the Top of Each Page", "Header Rows", 3, 3000, 3000)
ppi = InputBox("Input Points Per Inch", "Row Height", 77, 3000, 3000)
rowGrp = InputBox("Input Number of Rows in Each Item Group", _
"Rows Each Group", 7, 3000, 3000)
InchsPrntd = InputBox(" Input Printed Page Height In Inches", "Page Height", 9, 3000, 3000)
pgH = ppi * InchsPrntd
pbRowBgn = pbRowBgn + 1
Application.ScreenUpdating = False
Dim rowGrow(1 To 5) As Integer
rowGrow(1) = 7
rowGrow(2) = 14
rowGrow(3) = 21
rowGrow(4) = 28
rowGrow(5) = 35
Dim pbRng As Range
Dim rOne, rTwo, rThree, rFour, rFive As Integer
Dim blnkSpace As Integer
ActiveSheet.ResetAllPageBreaks
Set pbRng = Range("Print_Area")
pbRowEnd = pbRowBgn + rowGrp - 1
Do
Do
If Range(pbRng(pbRowBgn, 1), pbRng(pbRowEnd, 1)).Height > pgH Then
ActiveSheet.HPageBreaks.Add Before:=Rows(pbRowEnd - rowGrp + 1)
rOne = pbRowEnd - rowGrow(1)
rTwo = pbRowEnd - rowGrow(2)
rThree = pbRowEnd - rowGrow(3)
rFour = pbRowEnd - rowGrow(4)
rFive = pbRowEnd - rowGrow(5)
If Range(pbRng(pbRowBgn, 1), pbRng(pbRowEnd - 7, 1)).Height < 643 Then GoTo 1
1 blnkSpace = 693 - Range(pbRng(pbRowBgn, 1), pbRng(pbRowEnd - 7, 1)).Height
If (pbRowEnd - pbRowBgn = 34) Then
Cells(rOne, 1).Select
Selection.RowHeight = blnkSpace / 4
Cells(rTwo, 1).Select
Selection.RowHeight = blnkSpace / 4
Cells(rThree, 1).Select
Selection.RowHeight = blnkSpace / 4
Cells(rFour, 1).Select
Selection.RowHeight = blnkSpace / 4
Else
2 blnkSpace = 693 - Range(pbRng(pbRowBgn, 1), pbRng(pbRowEnd - 7, 1)).Height
If (pbRowEnd - pbRowBgn = 41) Then
Cells(rOne, 1).Select
Selection.RowHeight = blnkSpace / 5
Cells(rTwo, 1).Select
Selection.RowHeight = blnkSpace / 5
Cells(rThree, 1).Select
Selection.RowHeight = blnkSpace / 5
Cells(rFour, 1).Select
Selection.RowHeight = blnkSpace / 5
Cells(rFive, 1).Select
Selection.RowHeight = blnkSpace / 5
End If
End If
Exit Do
Else
pbRowEnd = pbRowEnd + rowGrp
End If
Loop While pbRowEnd < pbRng.Rows.Count
pbRowBgn = pbRowEnd - rowGrp + 1
pbRowEnd = pbRowBgn + rowGrp - 1
Loop While pbRowBgn < pbRng.Rows.Count
Application.ScreenUpdating = True
End Sub

Tis a bit convoluted (stuck in loops) and if anyone cares to suggest something more elegant . . . feel free.

Later - SG
 

Watch MrExcel Video

Forum statistics

Threads
1,123,366
Messages
5,601,208
Members
414,434
Latest member
Riyen

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
Top