Private Function Store_PT_FilterItems(PT As PivotTable, _
sField As String) As Variant
'---Stores visible items in PivotField sField in an array
Dim sVisibleItems() As String
Dim pviItem As PivotItem
Dim i As Long
'---make array of visible items in PT
With PT.PivotFields(sField)
If .Orientation = xlPageField And _
.EnableMultiplePageItems = False Then
ReDim sVisibleItems(1)
sVisibleItems(0) = .CurrentPage
Else
For Each pviItem In .PivotItems
If pviItem.Visible Then
i = i + 1
ReDim Preserve sVisibleItems(i)
sVisibleItems(i - 1) = pviItem
End If
Next
End If
End With
Store_PT_FilterItems = sVisibleItems
End Function
Private Function Filter_PivotField(pvtField As PivotField, _
vItems As Variant)
'---Filters the PivotField to make stored vItems Visible
Dim sItem As String, bTemp As Boolean, i As Long
On Error Resume Next
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
If Not (IsArray(vItems)) Then
vItems = Array(vItems)
End If
With pvtField
.Parent.ManualUpdate = True
If .Orientation = xlPageField Then .EnableMultiplePageItems = True
If vItems(0) = "(All)" Then
For i = 1 To .PivotItems.Count
If Not .PivotItems(i).Visible Then _
.PivotItems(i).Visible = True
Next i
Else
For i = LBound(vItems) To UBound(vItems)
bTemp = Not (IsError(.PivotItems(vItems(i)).Visible))
If bTemp Then
sItem = .PivotItems(vItems(i))
Exit For
End If
Next i
If sItem = "" Then
MsgBox "None of filter list items found."
GoTo CleanUp
End If
.PivotItems(sItem).Visible = True
For i = 1 To .PivotItems.Count
If IsError(Application.Match(.PivotItems(i), _
vItems, 0)) = .PivotItems(i).Visible Then
.PivotItems(i).Visible = Not (.PivotItems(i).Visible)
End If
Next i
End If
End With
CleanUp:
pvtField.Parent.ManualUpdate = False
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Function
Private Function Filter_AutoFilterField(rAutoFilterCell As Range, _
sHeader As String, vItems As Variant)
'---AutoFilters Current Region of rAutoFilterCell using the Field
' matching sHeader and criteria in array vItems.
Dim lField As Long
On Error Resume Next
lField = Application.Match(sHeader, _
rAutoFilterCell.CurrentRegion.Resize(1), 0)
If lField = 0 Then
MsgBox "Header: " & sHeader & " not found"
Else
If vItems(0) = "(All)" Then vItems(0) = "*"
rAutoFilterCell.AutoFilter Field:=lField, _
Criteria1:=vItems, Operator:=xlFilterValues
End If
End Function
ffice
