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:
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.
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:
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:
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:
'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:
SelectPivotFieldSubtotals ActiveCell.PivotField
End Sub
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.
Jeff,
It would be a good idea for someone who would like to understand clearly and see how the process works based on the macros you have mentioned herewith within your blog to have a workbook that can be downloaded and use it to understand clearly the process? This would be appreciated by the users who visit your blog. Don’t you think so?
Keep up the good work!
Cheers!
Thanks Chuck,
I very often do post sample workbooks, but didn’t do it this time. I agree that it’s helpful, but sometimes there’s just not enough time.
Very informative article, great work
thanks for sharing, Keep up the good work!
Thanks Shobi!