VBA procedures to rebuild, filter and modify pivot tables

PivotActions.cls

Option Explicit
Private pvt As PivotTable
Private blnUpdate As Boolean
Private varPivotTables As Variant
Enum OrientationType
    RowField = 1
    ColumnField = 2
    PageField = 3
    DataField = 4
End Enum
Enum DataFieldType
    Sum = -4157
    Count = -4112
    Average = -4106
End Enum
Sub ManualUpdateMode(blnManualMode As Boolean)
 
'change pivot manual update mode to True/False
 
pvt.ManualUpdate = blnManualMode
 
End Sub
Sub ShowGrandTotals(blnColumn As Boolean, blnRow As Boolean)
 
'display pivot table grand totals on rows and columns
 
With pvt
 
    .ColumnGrand = blnColumn
    .RowGrand = blnRow
    
End With
 
End Sub
Property Get CountPivotFields(eType As OrientationType) As Integer
 
'this property counts the number of fields displayed in particular group/orientation
 
Dim intCounter As Integer
Dim pf As PivotField
 
For Each pf In pvt.PivotFields
 
    If pf.Orientation = eType Then
    
        intCounter = intCounter + 1
    
    End If
 
Next pf
 
CountPivotFields = intCounter
 
End Property
Sub SortField(strFieldName As String, intSortMethod As Integer)
 
'xlAscending - 1
 
pvt.PivotFields(strFieldName).AutoSort intSortMethod, strFieldName
 
End Sub
Property Set SetPivotTableObject(pivot As PivotTable)
 
Set pvt = pivot
 
End Property
Sub SetPivotTable(strSheetName As String, strPivotName As String)
 
If strSheetName = "" Or strPivotName = "" Then
    MsgBox "Sheet name and pivot table name were not provided."
    Exit Sub
Else
    If CheckIfInArray(varPivotTables, strSheetName & "!" & strPivotName) Then
        Set pvt = Sheets(strSheetName).PivotTables(strPivotName)
        pvt.ManualUpdate = True
    End If
End If
 
End Sub
Sub RefreshPivotTable()
 
pvt.PivotCache.Refresh
 
End Sub
Sub HidePivotField(strFieldName As String)
 
On Error Resume Next
pvt.PivotFields(strFieldName).Orientation = xlHidden
On Error GoTo 0
 
End Sub
Sub HideAllFields()
 
Dim pf As PivotField
 
With pvt
    
    For Each pf In .PivotFields
    
        On Error Resume Next
        pf.Orientation = xlHidden
        On Error GoTo 0
    
    Next pf
    
End With
 
End Sub
Sub AddDataField(strFieldName As String, strFieldAlias As String, eType As DataFieldType)
 
On Error Resume Next
pvt.AddDataField pvt.PivotFields(strFieldName), strFieldAlias, eType
On Error GoTo 0
 
If Err.Number <> 0 Then
 
    MsgBox "Unable to add data field " & strFieldName & "." & vbCrLf & "Error description: " & Err.Description, vbCritical
    Err.Clear
 
End If
 
End Sub
Sub ShowPivotField(strFieldName As String, eType As OrientationType, intPosition As Integer)

Dim pvtField As PivotField

If intPosition < 0 Then MsgBox "Unable to set " & strFieldName & " in " & intPosition & " position.", vbCritical, "Incorrect position number!"
 
On Error Resume Next
With pvt.PivotFields(strFieldName)
 
    .Orientation = eType
    .Position = intPosition
    
End With

Set pvtField = pvt.PivotFields(strFieldName)
If pvtField Is Nothing Then
 
    MsgBox "Unable to display " & strFieldName & "." & vbCrLf & "Error description: " & Err.Description, vbCritical
    Err.Clear
 
End If
Set pvtField = Nothing
On Error GoTo 0
 
End Sub
Sub ShowTopItems(strDisplayTopFieldName As String, strCountTopFieldName As String, intTopValue As Integer)

pvt.PivotFields(strDisplayTopFieldName).PivotFilters.Add2 Type:=xlTopCount, DataField:=pvt.PivotFields(strCountTopFieldName), Value1:=intTopValue

End Sub
Sub ShowAllItemsInPivotField(strFieldName As String)
 
Dim pi As PivotItem
 
With pvt.PivotFields(strFieldName)
    
    For Each pi In .PivotItems
    
        On Error Resume Next
        pi.Visible = True
        On Error GoTo 0
   
    Next pi
 
End With
 
End Sub
Sub ApplyPivotFilter(strPivotFieldName As String, Optional varValue As Variant)
 
Dim varTemp As Variant
Dim pi As PivotItem
Dim i As Integer
Dim blnMatch As Boolean
 
If Not IsArray(varValue) Then
 
    MsgBox "ApplyPivotFilter procedure failed to apply filters. Provided variable is not an array!"
    Exit Sub
 
End If
 
With pvt.PivotFields(strPivotFieldName)
  
    On Error GoTo ErrHandler
    
    'for each pi check if it is in array
    For Each pi In .PivotItems
        
        blnMatch = False
        For i = LBound(varValue) To UBound(varValue)
        
            If UCase(CStr(pi.Name)) = UCase(CStr(varValue(i))) Then blnMatch = True
        
        Next i
        
        If Not blnMatch Then pi.Visible = False
                          
    Next pi
    
    On Error GoTo 0
 
End With
 
Exit Sub
 
ErrHandler:
MsgBox "The filter " & varValue & " cannot be applied to " & strPivotFieldName & "."
 
End Sub
Private Sub Class_Initialize()
 
Dim sht As Worksheet
Dim pvt As PivotTable
Dim varTempList As Variant
 
'gather information about all existing pivot tables
ReDim varTempList(0 To 0)
For Each sht In ThisWorkbook.Sheets
 
    For Each pvt In sht.PivotTables
    
        ReDim Preserve varTempList(1 To UBound(varTempList) + 1)
        varTempList(UBound(varTempList)) = sht.Name & "!" & pvt.Name
    
    Next pvt
 
Next sht
 
varPivotTables = varTempList
 
End Sub
Private Sub Class_Terminate()
 
If Not pvt Is Nothing Then
 
    pvt.Update
    pvt.ManualUpdate = False
 
End If
 
End Sub
Sub AddFilterSelection(strPivotFieldName As String, strSelection As String)
 
'add filter to existing selection / it does not remove other items
 
Dim pvtItem As PivotItem
 
With pvt.PivotFields(strPivotFieldName)
 
    For Each pvtItem In .PivotItems
    
        If pvtItem.Name = strSelection Then pvtItem.Visible = True
    
    Next pvtItem
 
End With
 
End Sub
Private Function CheckIfInArray(varArr As Variant, strLookUpValue As String) As Boolean
 
Dim lngLBound1D As Long
Dim lngUBound1D As Long
Dim lngLBound2D As Long
Dim lngUBound2D As Long
Dim i As Long
Dim j As Long
 
If Not IsArray(varArr) Then CheckIfInArray = False: Exit Function
 
Select Case GetArrDimension(varArr)
 
    Case 1
        lngLBound1D = LBound(varArr, 1)
        lngUBound1D = UBound(varArr, 1)
        
        For i = lngLBound1D To lngUBound1D
        
            If CStr(varArr(i)) = CStr(strLookUpValue) Then CheckIfInArray = True: Exit Function
        
        Next i
    
    Case 2
        lngLBound1D = LBound(varArr, 1)
        lngUBound1D = UBound(varArr, 1)
        lngLBound2D = LBound(varArr, 2)
        lngUBound2D = UBound(varArr, 2)
        
        For i = lngLBound1D To lngUBound1D
            For j = lngLBound2D To lngUBound2D
        
                If CStr(varArr(i, j)) = CStr(strLookUpValue) Then CheckIfInArray = True: Exit Function
        
            Next j
        Next i
    
    
    Case Else
        CheckIfInArray = False: Exit Function
 
End Select
 
End Function
Private Function GetArrDimension(varArr As Variant) As Integer
 
Dim i As Integer
Dim j As Integer
 
On Error GoTo ErrHandler:
 
    i = 0
    Do While True
        i = i + 1
        j = UBound(varArr, i)
    Loop
    
ErrHandler:
    GetArrDimension = i - 1
    
End Function