Learn when you want, where you want with convenient online training courses. Sign up now!
Experts Exchange Solution brought to you by
"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.
' Careful - Excel has a maximum of 1,026 horizontal/vertical Page breaks in Excel 2010 (and less in some earlier versions).
Dim i As Long
Dim xWork As Long
Dim xView As Long
Dim xCount As Long
Dim xLast_Row As Long
Dim xResponse As Long
Dim xStart_Row As Long
Dim xStart_Page As Long
Dim xData As Variant
Dim xTemp As Variant
Dim xStartTime As Variant
xLast_Row = ActiveSheet.UsedRange.Cells(1, 1).Row + ActiveSheet.UsedRange.Rows.Count - 1
If xLast_Row < 2 Then
MsgBox ("No data found - run cancelled.")
xResponse = MsgBox("About to ""Group"" Sheet1 in " & ActiveWorkbook.Name & "." _
& Chr(10) & " - This could take a long time." _
& Chr(10) & " - Manual Page Breaks will be cleared." _
& Chr(10) & " - The Print Area will be reset." _
& Chr(10) & " - Autofilter will be turned off." _
& Chr(10) & Chr(10) & "('OK' to Continue, 'Cancel' to Quit.)", vbOKCancel, "Group_Entries")
If xResponse = 2 Then
MsgBox ("User chose to cancel - run terminating.")
xStartTime = Timer
Application.ScreenUpdating = False
' Autofilter can cause issues with Page Breaks, so turn if off, if necessary...
If ActiveSheet.AutoFilterMode Then Selection.AutoFilter
' Print Area can cause issues with Page Breaks, so blank it if it's been set...
If ActiveSheet.PageSetup.PrintArea <> "" Then ActiveSheet.PageSetup.PrintArea = ""
If ActiveWindow.View <> xlNormalView Then
xView = ActiveWindow.View
ActiveWindow.View = xlNormalView
Cells.PageBreak = xlNone
If xView > 1 Then ActiveWindow.View = xView
xData = Range("A1:A" & xLast_Row)
xStart_Page = 0
For i = 1 To UBound(xData)
If i < UBound(xData) Then xTemp = xData(i + 1, 1) Else xTemp = ""
If (xData(i, 1) = "" And xTemp <> "") Or i = xLast_Row Then ' Last entry of a Group...
If xStart_Page <> 0 Then ' So it's neither the first group, nor is the Goup already at the start of a new page.
xWork = Page_of_Cell(Range("A" & i))
' Debug.Print xStart_Page & " - " & xWork
If xStart_Page <> xWork Then ' Group has crossed a page, so we start it on a new page
xCount = xCount + 1
ActiveSheet.HPageBreaks.Add Before:=Range("A" & xStart_Row)
' Debug.Print "Break #" & xcount & " inserted - " & Range("A" & xStart_Row).Address
ElseIf xData(i, 1) <> "" Then ' First entry of a Group...
xStart_Page = Page_of_Cell(Range("A" & i))
If i = 1 Then
xWork = 0 ' Careful with the first row!
xWork = Page_of_Cell(Range("A" & i - 1)) ' Get the previous row's Page No. in case this Group already starts a page.
If xWork <> xStart_Page Then
xStart_Page = 0 ' Already at the start of a page.
xStart_Row = i ' Not at the start of a page, so remember the Gtoup's first Row.
Application.ScreenUpdating = True
Debug.Print "Grouping complete. " & xCount & " Page Breaks inserted in " & Format(Timer - xStartTime, "#,##0") & " seconds."
MsgBox "Grouping complete. " & xCount & " Page Breaks inserted in " & Format(Timer - xStartTime, "#,##0") & " seconds."
Function Page_of_Cell(xcell As Range) As Long
' We only need to know whether we're on a *different* page, so this saves a bit of time by ignoring vertical page breaks and so may not give the *actual* page.
' (Underlying idea from http://www.pcreview.co.uk/forums/add-page-number-and-pages-number-cell-t1034189.html)
Dim i As Long
Dim xTemp As Long
Dim xPage As Long
'Force Excel to recalculate the number of pages...
If ActiveSheet.PageSetup.Pages().Count = 0 Then Debug.Print "This message only appears for an empty sheet."
xPage = 1
For i = 1 To ActiveSheet.HPageBreaks.Count
xTemp = 0
On Error Resume Next
xTemp = ActiveSheet.HPageBreaks(i).Location.Row
On Error GoTo 0
If xTemp = 0 Or xTemp > xcell.Row Then Exit For
xPage = xPage + 1
Page_of_Cell = xPage
Open in new window
Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.
From novice to tech pro — start learning today.
Premium members can enroll in this course at no extra cost.