Insert Page Breaks and Adjust Rows XL2003

[SonGunnar]

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

 

[SonGunnar]

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