Locating PivotItem Subtotals

Locating PivotItem Subtotals

I’m either on a roll or in a rut: here’s one more post about pivot field stuff. Last time I posted about determining whether a give pivot field has visible subtotals. This time I’ll tell you how to find them. The solution again relies on my new friend, the PivotCell object. My main function actually locates PivotItem subtotals, not a PivotField’s. I then wrap that function in another routine to deal with all of a PivotField’s PivotItems.

Here’s the VBA:

Function GetPivotItemSubtotalRanges(pvtItem As Excel.PivotItem) As Excel.Range()
Dim pvt As Excel.PivotTable
Dim pvtField As Excel.PivotField
Dim cell As Excel.Range
Dim ItemTester As Excel.PivotItem
Dim PivotItemSubtotalRanges() As Excel.Range

If Not pvtItem.Visible Then
   Exit Function
End If

'I can't figure a better way to get the containing pivot table
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 PivotItemSubtotalRanges
            If pvtField.Orientation = xlColumnField Then
               Set PivotItemSubtotalRanges(UBound(PivotItemSubtotalRanges)) = Intersect(cell.EntireColumn, pvt.DataBodyRange)
            ElseIf pvtField.Orientation = xlRowField Then
               Set PivotItemSubtotalRanges(UBound(PivotItemSubtotalRanges)) = Intersect(cell.EntireRow, pvt.DataBodyRange)
            End If
         End If
      End If
   End With
Next cell

GetPivotItemSubtotalRanges = PivotItemSubtotalRanges
End Function

How It Works

Be sure to read the previous post on this topic for background of how I got here.

With that background in hand, what the function above does is fairly simple. It loops through the RowRange and ColumnRange of a PivotItem’s pivot table. It looks for cells with a Range.PivotItem property that matches the PivotItem passed to the function, and which have a Range.PivotCellType of Subtotal or CustomSubtotal. If so then that PivotItem subtotal range is set to the intersection of the pivot table’s DataBodyRange and the row or column of the cell being tested. The subtotal range is added to the array of subtotal ranges returned by the function.

The PivotField Routine

Here’s an example of using the GetPivotItemSubtotalRanges function. This Sub takes a PivotField as its argument and selects all of it’s subtotals.

Sub SelectPivotFieldSubtotals(pvtField As Excel.PivotField)
   Dim pvtItem As Excel.PivotItem
   Dim PivotItemSubtotalRanges() As Excel.Range
   Dim PivotFieldSubtotals As Excel.Range
   Dim i As Long

   If Not PivotFieldSubtotalsVisible(pvtField) Then
      MsgBox "No Visible Subtotals"
      GoTo exit_point
   End If
   For Each pvtItem In pvtField.PivotItems
      If pvtItem.RecordCount > 0 Then
         PivotItemSubtotalRanges = GetPivotItemSubtotalRanges(pvtItem)
         For i = LBound(PivotItemSubtotalRanges) To UBound(PivotItemSubtotalRanges)
            If PivotFieldSubtotals Is Nothing Then
               Set PivotFieldSubtotals = PivotItemSubtotalRanges(i)
            Else
               Set PivotFieldSubtotals = Union(PivotFieldSubtotals, PivotItemSubtotalRanges(i))
            End If
         Next i
      End If
   Next pvtItem
   If i > 0 Then
      PivotFieldSubtotals.Select
   End If

exit_point:
End Sub

Stray Code Bits You’ll Need to Run the Above

This is the function that checks whether a PivotField has visible subtotals, and that I posted about previously:

Function PivotFieldSubtotalsVisible(pvtFieldToCheck As Excel.PivotField) As Boolean
Dim pvt As Excel.PivotTable
Dim 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
   End If
   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
            PivotFieldSubtotalsVisible = True
            GoTo exit_point
         End If
      End If
   Next cell
End With

exit_point:
End Function

This one is because I want to hide the fact that I’m Redimming a lot:

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

This is Chip Pearson’s array check:

Public Function IsArrayEmpty(Arr As Variant) As Boolean
'Chip Pearson
Dim LB As Long
Dim UB As Long

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

And this is what I attached to a button. Select a cell in a pivot table and if that cell’s PivotField has subtotals they will be highlighted:

Sub test()
SelectPivotFieldSubtotals ActiveCell.PivotField
End Sub

Subtotals Selected

In Conclusion

Whew! That feels like a lot of code with maybe not enough explanation. I plan to wrap up all this pivot field selection stuff soon with a post about my new-and-improved Per-Item Conditional Formatting tool.

Speak Your Mind

Your email address will not be published. Required fields are marked *

To post code, do this: <code> your vba here </code>