Pivot table VBA macro that works on both OLAP and standard pivot tables while running from personal.xlsb

insaneoctane

insaneoctane

Board Regular
Joined
Dec 2, 2005
Messages
72
I keep getting handed pivot tables to work with- sometimes regular, sometimes OLAP. One thing in common is they always have a column of data that I need to filter with the same values. I had an idea to write a VBA macro in my personal.xlsb file so it would always be accessible to me as I open yet another pivot table file and need to filter the data. I wanted to put the cursor (activecell) in the pivot field that contains my filter list since the name of the pivotfield would always be different from table to table. I wanted to use the activecell to identify the pivotfield in question and then filter from my pre-determined list (see FilterArray below). I wrote it, initially for regular pivot data below, but then learned on my first try that I was also receiving OLAP data and it didn't work. Can I get some help on making the below macro work for either standard or OLAP as described?

VBA Code: 
Sub Pivot_filterCC()
    Dim PT As PivotTable
  
    FilterArray = Array("42633", "42614", "42612")

    Dim myPivotField As PivotField

    Set myPivotField = ActiveCell.PivotField
    myPivotField.ClearAllFilters
    myPivotField.EnableMultiplePageItems = True
  
    numberOfElements = UBound(FilterArray) - LBound(FilterArray) + 1
  
    If numberOfElements > 0 Then
        With myPivotField
            For i = 1 To myPivotField.PivotItems.Count
                j = 0
                Do While j < numberOfElements
                    If myPivotField.PivotItems(i).Name = FilterArray(j) Then
                        myPivotField.PivotItems(myPivotField.PivotItems(i).Name).Visible = True
                        Exit Do
                    Else
                        myPivotField.PivotItems(myPivotField.PivotItems(i).Name).Visible = False
                    End If
                    j = j + 1
                Loop
            Next i
        End With
    End If

End Sub

FWIW- My actual FilterArray will actually contain 10 items (lots of clicks when doing manually) and the selection to choose from has thousands of options (making finding them difficult), hence why I'm looking to automate!
 

Excel Facts

Lock one reference in a formula
Need 1 part of a formula to always point to the same range? use $ signs: $V$2:$Z$99 will always point to V2:Z99, even after copying
Sort by date Sort by votes
Give this a try.
VBA Code: 
Sub Pivot_filterCC()
    Dim PT As PivotTable
    Dim FilterArray As Variant, OLAPFldSplit As Variant, OLAPFldName As String
    Dim bFilterFound As Boolean
    Dim numberOfElements As Long
    Dim isOLAP As Boolean
    Dim i As Long, j As Long
  
    FilterArray = Array("42633", "42614", "42612")

    Dim myPivotField As PivotField

    Set PT = ActiveCell.PivotTable
    Set myPivotField = ActiveCell.PivotField
    isOLAP = PT.PivotCache.OLAP
    
    myPivotField.ClearAllFilters
    
    If isOLAP Then
        ' Construct OLAP Pivot Field Name (Remove .Caption part included in the .Name)
        OLAPFldSplit = Split(myPivotField.Name, ".")
        OLAPFldName = OLAPFldSplit(0)
        For i = 1 To UBound(OLAPFldSplit) - 1
            OLAPFldName = OLAPFldName & "." & OLAPFldSplit(i)
        Next i
        ' Add Field Item Value to be used for Filter
        For i = 0 To UBound(FilterArray)
            FilterArray(i) = OLAPFldName & ".&[" & FilterArray(i) & "]"
        Next i
        ' Apply Filter
        On Error Resume Next
        myPivotField.VisibleItemsList = Array(FilterArray)
        If Err = 0 Then
            bFilterFound = True
        End If
    Else
        myPivotField.EnableMultiplePageItems = True
        numberOfElements = UBound(FilterArray) - LBound(FilterArray) + 1
  
        If numberOfElements > 0 Then
            With myPivotField
                For i = 1 To myPivotField.PivotItems.Count
                    j = 0
                    Do While j < numberOfElements
                        If myPivotField.PivotItems(i).Name = FilterArray(j) Then
                            myPivotField.PivotItems(myPivotField.PivotItems(i).Name).Visible = True
                            bFilterFound = True
                            Exit Do
                        Else
                            On Error Resume Next
                            myPivotField.PivotItems(myPivotField.PivotItems(i).Name).Visible = False
                            On Error GoTo 0
                        End If
                        j = j + 1
                    Loop
                Next i
            End With
        End If
    End If
    
    If bFilterFound = False Then
        myPivotField.ClearAllFilters
        MsgBox "No Items met any of the Filter Criteria - No Filter applied" & vbCrLf & _
                "Check the if the right field is selected in the pivot table"
    End If
  
End Sub
 
Upvote 0
Alex Blakenburg said:
Give this a try.
VBA Code: 
Sub Pivot_filterCC()
    Dim PT As PivotTable
    Dim FilterArray As Variant, OLAPFldSplit As Variant, OLAPFldName As String
    Dim bFilterFound As Boolean
    Dim numberOfElements As Long
    Dim isOLAP As Boolean
    Dim i As Long, j As Long
 
    FilterArray = Array("42633", "42614", "42612")

    Dim myPivotField As PivotField

    Set PT = ActiveCell.PivotTable
    Set myPivotField = ActiveCell.PivotField
    isOLAP = PT.PivotCache.OLAP
   
    myPivotField.ClearAllFilters
   
    If isOLAP Then
        ' Construct OLAP Pivot Field Name (Remove .Caption part included in the .Name)
        OLAPFldSplit = Split(myPivotField.Name, ".")
        OLAPFldName = OLAPFldSplit(0)
        For i = 1 To UBound(OLAPFldSplit) - 1
            OLAPFldName = OLAPFldName & "." & OLAPFldSplit(i)
        Next i
        ' Add Field Item Value to be used for Filter
        For i = 0 To UBound(FilterArray)
            FilterArray(i) = OLAPFldName & ".&[" & FilterArray(i) & "]"
        Next i
        ' Apply Filter
        On Error Resume Next
        myPivotField.VisibleItemsList = Array(FilterArray)
        If Err = 0 Then
            bFilterFound = True
        End If
    Else
        myPivotField.EnableMultiplePageItems = True
        numberOfElements = UBound(FilterArray) - LBound(FilterArray) + 1
 
        If numberOfElements > 0 Then
            With myPivotField
                For i = 1 To myPivotField.PivotItems.Count
                    j = 0
                    Do While j < numberOfElements
                        If myPivotField.PivotItems(i).Name = FilterArray(j) Then
                            myPivotField.PivotItems(myPivotField.PivotItems(i).Name).Visible = True
                            bFilterFound = True
                            Exit Do
                        Else
                            On Error Resume Next
                            myPivotField.PivotItems(myPivotField.PivotItems(i).Name).Visible = False
                            On Error GoTo 0
                        End If
                        j = j + 1
                    Loop
                Next i
            End With
        End If
    End If
   
    If bFilterFound = False Then
        myPivotField.ClearAllFilters
        MsgBox "No Items met any of the Filter Criteria - No Filter applied" & vbCrLf & _
                "Check the if the right field is selected in the pivot table"
    End If
 
End Sub
Click to expand...
Wow. Excellent. Thank you so much!

I did find one issue with the 2nd pivot I tested on....it doesn't work at all if the items in the filter array are not ALL present in the pivot table. Unfortunately, the data I receive often contains only some of the items in the filter array. Is there a way to apply only the filter array values that are actually found/present vs applying none if they aren't all present??

Again, thank you for your solution so far!
 
Upvote 0
insaneoctane said:
Wow. Excellent. Thank you so much!

I did find one issue with the 2nd pivot I tested on....it doesn't work at all if the items in the filter array are not ALL present in the pivot table. Unfortunately, the data I receive often contains only some of the items in the filter array. Is there a way to apply only the filter array values that are actually found/present vs applying none if they aren't all present??

Again, thank you for your solution so far!
Click to expand...
I found another difficulty with the script that I'm not skilled enough to fix. Even with a customized filter that WILL work (manually adjusted via VBA array ahead of time), it still doesn't work if the pivot field hasn't already pre-selected "Select Multiple Items". When I use VBA macro to try and automate this, it seems to want to use a "CubeField(xx)" parameter that I don't know how to access/read from my active cell. Seems like adding a simple version of:
VBA Code: 
ActiveSheet.PivotTables("PivotTable1").CubeFields(24).EnableMultiplePageItems = True
Would work, but I'd need help with the syntax to automate CubeField number?

Thanks in advance
 
Upvote 0
insaneoctane said:
I found another difficulty with the script that I'm not skilled enough to fix. Even with a customized filter that WILL work (manually adjusted via VBA array ahead of time), it still doesn't work if the pivot field hasn't already pre-selected "Select Multiple Items". When I use VBA macro to try and automate this, it seems to want to use a "CubeField(xx)" parameter that I don't know how to access/read from my active cell. Seems like adding a simple version of:
VBA Code: 
ActiveSheet.PivotTables("PivotTable1").CubeFields(24).EnableMultiplePageItems = True
Would work, but I'd need help with the syntax to automate CubeField number?

Thanks in advance
Click to expand...
Missed my 10 minute edit window....I think I solved this one difficulty with this line:
VBA Code: 
ActiveCell.PivotField.CubeField.EnableMultiplePageItems = True
 
Upvote 0
Alex Blakenburg said:
Give this a try.
VBA Code: 
Sub Pivot_filterCC()
    Dim PT As PivotTable
    Dim FilterArray As Variant, OLAPFldSplit As Variant, OLAPFldName As String
    Dim bFilterFound As Boolean
    Dim numberOfElements As Long
    Dim isOLAP As Boolean
    Dim i As Long, j As Long
 
    FilterArray = Array("42633", "42614", "42612")

    Dim myPivotField As PivotField

    Set PT = ActiveCell.PivotTable
    Set myPivotField = ActiveCell.PivotField
    isOLAP = PT.PivotCache.OLAP
   
    myPivotField.ClearAllFilters
   
    If isOLAP Then
        ' Construct OLAP Pivot Field Name (Remove .Caption part included in the .Name)
        OLAPFldSplit = Split(myPivotField.Name, ".")
        OLAPFldName = OLAPFldSplit(0)
        For i = 1 To UBound(OLAPFldSplit) - 1
            OLAPFldName = OLAPFldName & "." & OLAPFldSplit(i)
        Next i
        ' Add Field Item Value to be used for Filter
        For i = 0 To UBound(FilterArray)
            FilterArray(i) = OLAPFldName & ".&[" & FilterArray(i) & "]"
        Next i
        ' Apply Filter
        On Error Resume Next
        myPivotField.VisibleItemsList = Array(FilterArray)
        If Err = 0 Then
            bFilterFound = True
        End If
    Else
        myPivotField.EnableMultiplePageItems = True
        numberOfElements = UBound(FilterArray) - LBound(FilterArray) + 1
 
        If numberOfElements > 0 Then
            With myPivotField
                For i = 1 To myPivotField.PivotItems.Count
                    j = 0
                    Do While j < numberOfElements
                        If myPivotField.PivotItems(i).Name = FilterArray(j) Then
                            myPivotField.PivotItems(myPivotField.PivotItems(i).Name).Visible = True
                            bFilterFound = True
                            Exit Do
                        Else
                            On Error Resume Next
                            myPivotField.PivotItems(myPivotField.PivotItems(i).Name).Visible = False
                            On Error GoTo 0
                        End If
                        j = j + 1
                    Loop
                Next i
            End With
        End If
    End If
   
    If bFilterFound = False Then
        myPivotField.ClearAllFilters
        MsgBox "No Items met any of the Filter Criteria - No Filter applied" & vbCrLf & _
                "Check the if the right field is selected in the pivot table"
    End If
 
End Sub
Click to expand...
I attempted a brute force method, where I test filter each member of the array and if it errors, I remove it from the final filter array. I'm sure there are faster performing methods?

VBA Code: 
Sub Pivot_filterCC()
    Dim PT As PivotTable
    Dim FilterArray As Variant, OLAPFldSplit As Variant, OLAPFldName As String, NewFilterArray As Variant
    Dim bFilterFound As Boolean
    Dim numberOfElements As Long
    Dim isOLAP As Boolean
    Dim i As Long, j As Long
    Dim cbf As CubeField
 
    FilterArray = Array("42633", "42614", "42612")
    NewFilterArray = Array("")
        
    Dim myPivotField As PivotField

    Set PT = ActiveCell.PivotTable
    Set myPivotField = ActiveCell.PivotField
    isOLAP = PT.PivotCache.OLAP
    
    myPivotField.ClearAllFilters
    
    If isOLAP Then
        ' Construct OLAP Pivot Field Name (Remove .Caption part included in the .Name)
        OLAPFldSplit = Split(myPivotField.Name, ".")
        OLAPFldName = OLAPFldSplit(0)
        For i = 1 To UBound(OLAPFldSplit) - 1
            OLAPFldName = OLAPFldName & "." & OLAPFldSplit(i)
        Next i
        ' Force Multi-selection option
        ActiveCell.PivotField.CubeField.EnableMultiplePageItems = True
        ' Add Field Item Value to be used for Filter
        ii = 0
        For i = 0 To UBound(FilterArray)
            NewFilterArray(ii) = OLAPFldName & ".&[" & FilterArray(i) & "]"
            On Error Resume Next
            myPivotField.VisibleItemsList = Array(NewFilterArray(ii))
            If Err = 0 Then
                ii = ii + 1 'No error, keep the last value
                ReDim Preserve NewFilterArray(ii)
            End If
        Next i
        If IsEmpty(NewFilterArray(ii)) Then ReDim Preserve NewFilterArray(ii - 1)
        ' Apply Filter
        On Error Resume Next
        myPivotField.VisibleItemsList = Array(NewFilterArray)
        If Err = 0 Then
            bFilterFound = True
        End If
    Else
        myPivotField.EnableMultiplePageItems = True
        numberOfElements = UBound(FilterArray) - LBound(FilterArray) + 1
 
        If numberOfElements > 0 Then
            With myPivotField
                For i = 1 To myPivotField.PivotItems.Count
                    j = 0
                    Do While j < numberOfElements
                        If myPivotField.PivotItems(i).Name = FilterArray(j) Then
                            myPivotField.PivotItems(myPivotField.PivotItems(i).Name).Visible = True
                            bFilterFound = True
                            Exit Do
                        Else
                            On Error Resume Next
                            myPivotField.PivotItems(myPivotField.PivotItems(i).Name).Visible = False
                            On Error GoTo 0
                        End If
                        j = j + 1
                    Loop
                Next i
            End With
        End If
    End If
    
    If bFilterFound = False Then
        myPivotField.ClearAllFilters
        MsgBox "No Items met any of the Filter Criteria - No Filter applied" & vbCrLf & _
                "Check the if the right field is selected in the pivot table"
    End If
 
End Sub
 
Upvote 0
insaneoctane said:
Missed my 10 minute edit window....I think I solved this one difficulty with this line:
VBA Code: 
ActiveCell.PivotField.CubeField.EnableMultiplePageItems = True
Click to expand...
You can replace that with:
Rich (BB code): 
myPivotField.CubeField.EnableMultiplePageItems = True

I have not come up with a better way to cater for missing items in the array used for the OLAP filter than you came up with.
I will have a bit more of a look but otherwise I might be tucking away what you had for future use ;)
 
Upvote 0
You might want to add the Else statement below that I have added to your code.
Without it if the very last Item in your filter array is not valid, it will still be included in your filter array and the code will still error out which is handled by clearing the filter.

Rich (BB code): 
        ' Add Field Item Value to be used for Filter
        ii = 0
        For i = 0 To UBound(FilterArray)
            NewFilterArray(ii) = OLAPFldName & ".&[" & FilterArray(i) & "]"
            On Error Resume Next
            myPivotField.VisibleItemsList = Array(NewFilterArray(ii))
            If Err = 0 Then
                ii = ii + 1 'No error, keep the last value
                ReDim Preserve NewFilterArray(ii)
            Else
                NewFilterArray(ii) = ""
            End If
        Next i
        If IsEmpty(NewFilterArray(ii)) Then ReDim Preserve NewFilterArray(ii - 1)
 
Upvote 0
The only alternative that I have seen is a slight variation on what you had, in that it tests each value on its own before putting it in the New Filter array.
By doing that you can avoid the Redim inside the loop and only need to do it once after the loop has completed.
I have made that modification in the code below as well to test if the selected cell is not inside a pivot table.

VBA Code: 
Sub Pivot_filterCC_CollaboratedVersion()
    Dim PT As PivotTable
    Dim FilterArray As Variant, OLAPFldSplit As Variant, OLAPFldName As String
    Dim NewFilterArray As Variant, FltrValue As String
    Dim bFilterFound As Boolean
    Dim numberOfElements As Long
    Dim isOLAP As Boolean
    Dim i As Long, j As Long, iNewFltr As Long
 
    FilterArray = Array("42612", "42614", "42633", "42698")
    NewFilterArray = Array("")
      
    Dim myPivotField As PivotField

    On Error Resume Next
    Set PT = ActiveCell.PivotTable
    If Err <> 0 Then
        MsgBox "Active Cell is not part of a pivot table - exiting Sub:"
        Exit Sub
    End If
    Set myPivotField = ActiveCell.PivotField
    isOLAP = PT.PivotCache.OLAP
  
    myPivotField.ClearAllFilters
  
    If isOLAP Then
        ' Construct OLAP Pivot Field Name (Remove .Caption part included in the .Name)
        OLAPFldSplit = Split(myPivotField.Name, ".")
        OLAPFldName = OLAPFldSplit(0)
        For i = 1 To UBound(OLAPFldSplit) - 1
            OLAPFldName = OLAPFldName & "." & OLAPFldSplit(i)
        Next i
        ' Force Multi-selection option
        myPivotField.CubeField.EnableMultiplePageItems = True

        ' Test Pivot Item exists before adding to New Filter
        ReDim NewFilterArray(0 To UBound(FilterArray))
        iNewFltr = 0
        For i = 0 To UBound(FilterArray)
            'NewFilterArray(ii) = OLAPFldName & ".&[" & FilterArray(i) & "]"
            On Error Resume Next
            FltrValue = OLAPFldName & ".&[" & FilterArray(i) & "]"
            myPivotField.VisibleItemsList = Array(FltrValue)
            If Err = 0 Then
                NewFilterArray(iNewFltr) = FltrValue
                iNewFltr = iNewFltr + 1
            End If
        Next i
      
        If iNewFltr <> 0 Then
            ' Apply Filter
            ReDim Preserve NewFilterArray(0 To iNewFltr - 1)
            myPivotField.VisibleItemsList = Array(NewFilterArray)
            bFilterFound = True
        Else
            bFilterFound = False
        End If
    Else
        myPivotField.EnableMultiplePageItems = True
        numberOfElements = UBound(FilterArray) - LBound(FilterArray) + 1
 
        If numberOfElements > 0 Then
            With myPivotField
                For i = 1 To myPivotField.PivotItems.Count
                    j = 0
                    Do While j < numberOfElements
                        If myPivotField.PivotItems(i).Name = FilterArray(j) Then
                            myPivotField.PivotItems(myPivotField.PivotItems(i).Name).Visible = True
                            bFilterFound = True
                            Exit Do
                        Else
                            On Error Resume Next
                            myPivotField.PivotItems(myPivotField.PivotItems(i).Name).Visible = False
                            On Error GoTo 0
                        End If
                        j = j + 1
                    Loop
                Next i
            End With
        End If
    End If
  
    If bFilterFound = False Then
        myPivotField.ClearAllFilters
        MsgBox "No Items met any of the Filter Criteria - No Filter applied" & vbCrLf & _
                "Check the if the right field is selected in the pivot table"
    End If
 
End Sub
 
Last edited:
Upvote 0
Solution
@Alex Blakenburg , thank you for all your assistance. I've finalized on the version you provided above (and marked it as the "answer"). I confirmed it worked on both OLAP and non-OLAP pivots. I may not recoup the time spend solving this very quickly, but it was enjoyable to write and learn the solution and it will make my many future filter configurating WONDERFUL. Thank you.
 
Upvote 0
You must log in or register to reply here.

Similar threads

insaneoctane
  • Question Question
Pivot filter macro run from personal.xlsb
Replies
5
Views
473
insaneoctane
insaneoctane
G
  • Question Question
Run-time error 5: Invalid procedure call or argument in PivotTable filter VBA
Replies
7
Views
3K
RoryA
RoryA
SanjayGMusafir
  • Solved
VBA to Filter Column Labels using Filter List
Replies
2
Views
2K
SanjayGMusafir
SanjayGMusafir
C
  • Question Question
VBA to keep the pivot tables from updating its filters in tandem
Replies
1
Views
693
Alex Blakenburg
A
V
  • Question Question
Trouble selecting date ranges with macro for pivot table from external source
Replies
0
Views
483
VBA Rando
V

Forum statistics

Threads
1,223,903
Messages
6,175,284
Members
452,630
Latest member
OdubiYouth

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top