Insert Page Break Auto

[sakiaa07]

Hi,

I have a pivot table that in which I need to insert page breaks automatically.I have 3 columns in my pivot table-1. Item Descriptions 2. Stores 3. Revenue. And the Item Description column has a subtotal after every different item description. I have 1000 plus item descriptions. So therefore there are over 1000 item descriptions subtotal.

It does not matter where the page break is inserted, I just want to automatically insert page breaks that maximize page space and they must end with a subtotal of the item description.

Does anyone have any ideas I can do this?

Cheers!

 

[Worf]

Hi

First thing is to know where the subtotals are. Tell me if the test routine below finds the initial ones correctly. If the string variable cannot hold all addresses we go for another method.
After checking that we can start inserting page breaks…

Sub test()
Dim p As PivotTable, pf As PivotField, s$, arr, i%, j%
Set p = ActiveSheet.PivotTables("pivot3")
s = "": j = 0
For Each pf In p.PivotFields
    s = s & SelPFSubT(pf) & ","
Next
arr = Split(s, ",")
For i = LBound(arr) To UBound(arr)
    If Len(arr(i)) > 2 Then
        MsgBox arr(i)
        j = j + 1
        If j > 10 Then Exit Sub
    End If
Next
End Sub


Function GetPISubTRanges(pvtItem As Excel.PivotItem) As Excel.Range()
' by @sumbuddy
Dim pvt As PivotTable, pvtField As PivotField, cell As Excel.Range, ItemTester As PivotItem
Dim PISubTRng() As Excel.Range
If Not pvtItem.Visible Then Exit Function
Set pvt = pvtItem.DataRange.Cells(1).PivotTable
Set pvtField = pvtItem.Parent
'Cells with subtotal PivotCellType are in ColumnRange or RowRange
For Each cell In Union(pvt.ColumnRange, pvt.RowRange)
   Set ItemTester = Nothing
   On Error Resume Next
   'Only test cells with an associated PivotItem
   Set ItemTester = cell.PivotItem
   On Error GoTo 0
   With cell.PivotCell
      If Not ItemTester Is Nothing Then
         If (.PivotCellType = xlPivotCellSubtotal Or .PivotCellType = xlPivotCellCustomSubtotal) _
         And cell.PivotField.DataRange.Address = pvtField.DataRange.Address And _
         cell.PivotItem.DataRange.Address = pvtItem.DataRange.Address Then
            RedimRanges PISubTRng
            If pvtField.Orientation = xlColumnField Then
               Set PISubTRng(UBound(PISubTRng)) = Intersect(cell.EntireColumn, pvt.DataBodyRange)
            ElseIf pvtField.Orientation = xlRowField Then
               Set PISubTRng(UBound(PISubTRng)) = Intersect(cell.EntireRow, pvt.DataBodyRange)
            End If
         End If
      End If
   End With
Next
GetPISubTRanges = PISubTRng
End Function


Sub RedimRanges(ByRef SubTDRng() As Excel.Range)
If IsArrayEmpty(SubTDRng) Then
    ReDim SubTDRng(1 To 1)
Else
    ReDim Preserve SubTDRng(LBound(SubTDRng) To UBound(SubTDRng) + 1)
End If
End Sub


Public Function IsArrayEmpty(arr) As Boolean
'Chip Pearson
Dim LB As Long, UB&
Err.Clear
On Error Resume Next
If IsArray(arr) = False Then
    ' we weren't passed an array, return True
    IsArrayEmpty = True
End If
UB = UBound(arr, 1)
If (Err.Number <> 0) Then
    IsArrayEmpty = True
Else
    Err.Clear
    LB = LBound(arr)
    If LB > UB Then
        IsArrayEmpty = True
    Else
        IsArrayEmpty = False
    End If
End If
End Function


Function SelPFSubT$(pvtField As PivotField)
Dim pvtItem As Excel.PivotItem, PISubTRng() As Excel.Range
Dim PFSubT As Excel.Range, i&
If Not PFSubTVisible(pvtField) Then GoTo exit_point
For Each pvtItem In pvtField.PivotItems
   If pvtItem.RecordCount > 0 Then
      PISubTRng = GetPISubTRanges(pvtItem)
      For i = LBound(PISubTRng) To UBound(PISubTRng)
         If PFSubT Is Nothing Then
            Set PFSubT = PISubTRng(i)
         Else
            Set PFSubT = Union(PFSubT, PISubTRng(i))
         End If
      Next
   End If
Next
SelPFSubT = PFSubT.Address
exit_point:
End Function


Function PFSubTVisible(pvtFieldToCheck As Excel.PivotField) As Boolean
Dim pvt As Excel.PivotTable, cell As Excel.Range
With pvtFieldToCheck
   'Only row and column fields can show subtotals,
   If Not (.Orientation = xlColumnField Or .Orientation = xlRowField) Then GoTo exit_point
   Set pvt = .Parent
   For Each cell In Union(pvt.ColumnRange, pvt.RowRange)
      If cell.PivotCell.PivotCellType = xlPivotCellSubtotal Or _
      cell.PivotCell.PivotCellType = xlPivotCellCustomSubtotal Then
         If cell.PivotCell.PivotField.Name = .Name Then
            PFSubTVisible = True
            GoTo exit_point
         End If
      End If
   Next
End With
exit_point:
End Function