Page Break Automation

[BEEJAY]

I tried Gord D.'s "clunker".
Couldn't get it to work, even with help from the group.
Then I found the following, apparently originally from Frank Kabel.
Works great, EXCEPT, it also puts a page break under the header.
Can someone tell me how to get the following to ignore header rows.
If I can specify (within the module), the number of header rows,
this macro would be very versatile. (for many people)
Just specify how many header rows there are,
and which column is to be searched......
and Bob's your uncle.

Sub AAAInsertBreak()
' AAAInsertBreak Macro
' Insert Page Break after each change of
' Data in Column B
' From Frank Kabel, Germany

' I added the following reset
ActiveSheet.ResetAllPageBreaks

Dim lastrow As Long
Dim row_index As Long

'All the "B"'s were "A"'s, originally

lastrow = ActiveSheet.Cells(Rows.Count, "B").End(xlUp).Row
For row_index = lastrow - 1 To 1 Step -1
If Cells(row_index, "B").Value <> _
Cells(row_index + 1, "B").Value Then
ActiveSheet.HPageBreaks.Add Before:= _
Cells(row_index + 1, "B")
End If
Next

'I added the Message Box
MsgBox "COMPLETE!"

End Sub

 

[keepITcool]

BEEJAY,

I've cooked s'thing. Not thoroughly tested, but give it a try.

It will look at TitleRows in PageSetup instead of your proposed setting
of a header variable.

it will not put a break before a blank,
but keep blanks with previous page.

it will not stop on cells containing errors like NA#.

it will compare cells caseInsensitive,
change vbTextCompare to vbBinaryCompare if you want)


let me know


Sub InsertPageBreakOnDataChange()
Const sCOL As String = "B"
Dim wks As Worksheet
Dim pgs As PageSetup
Dim rngD As Range
Dim rngH As Range
Dim r As Long

Set wks = ActiveSheet
Set pgs = wks.PageSetup


wks.ResetAllPageBreaks
wks.DisplayPageBreaks = False
wks.DisplayAutomaticPageBreaks = False

Application.ScreenUpdating = False

If pgs.PrintArea = vbNullString Then
Set rngD = wks.UsedRange
Else
Set rngD = wks.Range(pgs.PrintArea)
End If

If pgs.PrintTitleRows <> vbNullString Then
Set rngH = wks.Range(pgs.PrintTitleRows)
If rngD.Row < rngH.Row Then
MsgBox _
"PrintTitles must be above or toprows of PrintArea"
Exit Sub
ElseIf Not Intersect(rngH, rngD) Is Nothing Then
If rngD.Row + rngD.Rows.Count <= rngH.Row + _
rngH.Rows.Count Then
MsgBox "PrintArea must be larger than PrintTitles"
Exit Sub
End If
Set rngD = rngD.Resize( _
rngD.Rows.Count - rngH.Rows.Count).Offset( _
rngH.Rows.Count)
End If
End If

If Not rngD Is Nothing Then
Set rngD = Intersect(rngD.EntireRow, wks.Columns(sCOL))
End If

If Not rngD Is Nothing Then
On Error GoTo errH:
With rngD
For r = .Count To 1 Step -1
With .Cells(r)
If r > 1 And Not IsEmpty(.Value) Then
If StrComp(CStr(.Value), CStr(.Offset(-1).Value), _
vbTextCompare) Then
wks.HPageBreaks.Add rngD(r)
End If
End If
End With
Next
End With

End If
endH:
wks.DisplayPageBreaks = True
Application.ScreenUpdating = True
Exit Sub
errH:
MsgBox Err.Description, _
vbExclamation + vbMsgBoxHelpButton, "Oops!"
GoTo endH
End Sub





--
keepITcool
| www.XLsupport.com | keepITcool chello nl | amsterdam


BEEJAY wrote :

 

[BEEJAY]

Greetings:
Works great on my test sheet.
Next step, try it on COPY of original sheet.
Then, if all still OK, Study the code to learn from it.
I must confess that a lot of it is beyond me, at this point.
But I look forward to learning.
Thanks much for your prompt response.