fit data on new print page

I would like to insert a page break base on the values in the range cannot fit on the page something similar to ms access group together feature in report.
Book110xlsm.xlsm
SvgmassiveAsked:
Who is Participating?
I wear a lot of hats...

"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.

redmondbCommented:
Hi, Svgmassive.

Please see the attached. It's very flexible, handling anything I could think of. However, the result is that it's very slow. "Fancy" page setups, particularly "Fit to wide/tall", can slow it down even more.

Roughly how many rows and Groups do you expect to have?

The code is...
Option Explicit

Sub Group_Entries()
' 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

Sheets("Sheet1").Activate

xLast_Row = ActiveSheet.UsedRange.Cells(1, 1).Row + ActiveSheet.UsedRange.Rows.Count - 1
If xLast_Row < 2 Then
    MsgBox ("No data found - run cancelled.")
    Exit Sub
End If

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.")
    Exit Sub
End If

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
    End If
    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
                End If
            End If
        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!
            Else
                xWork = Page_of_Cell(Range("A" & i - 1))       ' Get the previous row's Page No. in case this Group already starts a page.
            End If
            If xWork <> xStart_Page Then
                xStart_Page = 0                                ' Already at the start of a page.
            Else
                xStart_Row = i                                 ' Not at the start of a page, so remember the Gtoup's first Row.
            End If
        End If
            
    Next
    
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."

End Sub

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
Next

Page_of_Cell = xPage

End Function

Open in new window

Regards,
Brian.Book110xlsm-V2.xlsm
0

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
SvgmassiveAuthor Commented:
great redmondb
0
redmondbCommented:
Thanks, Svgmassive.
0
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
Microsoft Excel

From novice to tech pro — start learning today.