Hi
I'm trying to insert a page break after a certain number (26) of
cells, with length =21, is exceeded
I've grabbed snippets of code from here and there but can't get it
to
work.
Any help would be appreciated

Thanks
Ritchi


Sub InsertPageBreak()
'insert a page break after the count of cells in column 1 with a
defined length (=21 by default) is exceeded (26 is the default count
to trigger a page insert)


Application.ScreenUpdating = False
ActiveSheet.Activate


Dim CountOfItems As Long
CountOfItems = 0


Call PageBreaksHorizontalRemove


lr = Cells(Rows.Count, 1).End(xlUp).Row
For i = lr To 6 Step -1
'For i = 6 To lr Step 1
If Len(Cells(i, 1)) = 21 Then CountOfItems = CountOfItems +
1
If CountOfItems = 26 Then
ActiveWindow.SelectedSheets.HPageBreaks.Add Befo=ActiveCell
If CountOfItems = 26 Then CountOfItems = 0
Next


Application.ScreenUpdating = True
End Sub


Sub PageBreaksHorizontalRemove()
'Remove all horizontal pagebreaks in active sheet
Dim pb As HPageBreak
Dim lCount As Long


For lCount = ActiveSheet.HPageBreaks.Count To 1 Step -1
Set pb = ActiveSheet.HPageBreaks(lCount)
If pb.Type = xlPageBreakManual Then pb.Delete
Next lCount


End Sub

This code worked for me:

Sub InsertPageBreak()

Dim CountOfItems As Long
Dim LastRow As Long
Dim CurrentRow As Long

CountOfItems = 0
LastRow = Cells(Rows.Count, 1).End(xlUp).Row

For CurrentRow = 2 To LastRow
If Len(Cells(CurrentRow, 1)) = 21 Then
CountOfItems = CountOfItems + 1
End If
If CountOfItems = 26 Then
ActiveSheet.HPageBreaks.Add befo=Cells(CurrentRow + 1, 1)
CountOfItems = 0
End If
Next CurrentRow

End Sub

"RITCHI" wrote:

Hi
I'm trying to insert a page break after a certain number (26) of
cells, with length =21, is exceeded
I've grabbed snippets of code from here and there but can't get it
to
work.
Any help would be appreciated

Thanks
Ritchi


Sub InsertPageBreak()
'insert a page break after the count of cells in column 1 with a
defined length (=21 by default) is exceeded (26 is the default count
to trigger a page insert)


Application.ScreenUpdating = False
ActiveSheet.Activate


Dim CountOfItems As Long
CountOfItems = 0


Call PageBreaksHorizontalRemove


lr = Cells(Rows.Count, 1).End(xlUp).Row
For i = lr To 6 Step -1
'For i = 6 To lr Step 1
If Len(Cells(i, 1)) = 21 Then CountOfItems = CountOfItems +
1
If CountOfItems = 26 Then
ActiveWindow.SelectedSheets.HPageBreaks.Add Befo=ActiveCell
If CountOfItems = 26 Then CountOfItems = 0
Next


Application.ScreenUpdating = True
End Sub


Sub PageBreaksHorizontalRemove()
'Remove all horizontal pagebreaks in active sheet
Dim pb As HPageBreak
Dim lCount As Long


For lCount = ActiveSheet.HPageBreaks.Count To 1 Step -1
Set pb = ActiveSheet.HPageBreaks(lCount)
If pb.Type = xlPageBreakManual Then pb.Delete
Next lCount


End Sub