VBA to Filter Column Labels using Filter List

SanjayGMusafir

Well-known Member
Joined
Sep 7, 2018
Messages
658
Office Version
  1. 2021
Platform
  1. MacOS
Hi Everyone
I need to filter my pivot table column label for Column "D1". I need this because everytime there is new item in D1, pivot table automatically clears all filters and starts showing all items.
Just to keep a record that which items I need to be seen, I created a list "PFilters" with column header "Name".
I searched internet and used following code to filter my pivot table. But what it does is that it counts number of entries in PFilters (e.g. 18) and hides First 18 Column "D1" labels and hangs...
I don't know where the challenge or error is. Please help me improve the VBA code. I'm quoting the VBA I'm using for your reference.
Thanks in advance.

VBA Code:
'To Filter D1 Field as per the given Range - But ask before using filter
    Dim x As Integer
    x = MsgBox("Do you want to Filter Columns?", vbQuestion + vbYesNo + vbDefaultButton1, "")
    
    If x = vbYes Then
        Dim vArray As Variant, i As Integer, j As Integer, PF3 As PivotField
        
        Set PF3 = ActiveSheet.PivotTables("ExpAnalysis").PivotFields("D1")
        vArray = Range("PFilters[Name]")
        PF3.ClearAllFilters
    
        With PF3
            For i = 1 To PF3.PivotItems.Count
                j = 1
                Do While j <= UBound(vArray, 1) - LBound(vArray, 1) + 1
                    If PF3.PivotItems(i).Name = vArray(j, 1) Then
                    PF3.PivotItems(PF3.PivotItems(i).Name).Visible = True
                    Exit Do
                 Else
                    PF3.PivotItems(PF3.PivotItems(i).Name).Visible = False
                End If
              j = j + 1
              Loop
            Next i
        End With
        
    Else
    End If
 

Excel Facts

Which lookup functions find a value equal or greater than the lookup value?
MATCH uses -1 to find larger value (lookup table must be sorted ZA). XLOOKUP uses 1 to find values greater and does not need to be sorted.

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
15,423
Office Version
  1. 2013
Platform
  1. Windows
Try this:

VBA Code:
Sub FilterPivotTableUsingFilterList()
  Dim pItm As PivotItem
  Dim FilterArr() As Variant, aItm As Variant
  Dim bExists As Boolean
  Dim n As Long
  
  Application.ScreenUpdating = False
  
  FilterArr = Range("PFilters[Name]").Value
  
  With ActiveSheet.PivotTables("ExpAnalysis").PivotFields("D1")
    .ClearAllFilters
    n = 0
    For Each pItm In .PivotItems
      bExists = False
      For Each aItm In FilterArr
        If LCase(aItm) = LCase(pItm.Value) Then
          bExists = True
          Exit For
        End If
      Next
      If bExists = False Then
        n = n + 1
        If n < .PivotItems.Count Then
          pItm.Visible = False
        Else
          .ClearAllFilters
        End If
      End If
    Next
  End With
  
  Application.ScreenUpdating = True
End Sub
 
Solution

SanjayGMusafir

Well-known Member
Joined
Sep 7, 2018
Messages
658
Office Version
  1. 2021
Platform
  1. MacOS
Try this:

VBA Code:
Sub FilterPivotTableUsingFilterList()
  Dim pItm As PivotItem
  Dim FilterArr() As Variant, aItm As Variant
  Dim bExists As Boolean
  Dim n As Long
 
  Application.ScreenUpdating = False
 
  FilterArr = Range("PFilters[Name]").Value
 
  With ActiveSheet.PivotTables("ExpAnalysis").PivotFields("D1")
    .ClearAllFilters
    n = 0
    For Each pItm In .PivotItems
      bExists = False
      For Each aItm In FilterArr
        If LCase(aItm) = LCase(pItm.Value) Then
          bExists = True
          Exit For
        End If
      Next
      If bExists = False Then
        n = n + 1
        If n < .PivotItems.Count Then
          pItm.Visible = False
        Else
          .ClearAllFilters
        End If
      End If
    Next
  End With
 
  Application.ScreenUpdating = True
End Sub
Thanks DanteAmor it worked like charm.
 

Forum statistics

Threads
1,181,940
Messages
5,932,888
Members
436,869
Latest member
ABGTH

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
Top