Filter pivot table off multiple reference cells?

[SURFER349]

So there's this tutorial to use a single cell
How to control Excel PIVOT tables from a cell value with VBA | Dedicated Excel

But what if I want to have multiple items filtering the pivot table? The below script is what I currently have. What if I want to use 2 different user inputs to filter the PivotTable by 2 values (the same as selecting two from the filter drop-down).?





Private Sub Worksheet_SelectionChange(ByVal Target As Range)

'This line stops the worksheet updating on every change, it only updates when cell
'A2 through A5 is touched
If Intersect(Target, Range("A2:A5")) Is Nothing Then Exit Sub

'Set the Variables to be used
Dim pt As PivotTable
Dim Field As PivotField
Dim NewCat As String

'Here you amend to suit your data
Set pt = Worksheets("Tab that contains PivotTable").PivotTables("PivotTable1")
Set Field = pt.PivotFields("FilterColumnName")
NewCat = Worksheets("Tab that contains PivotTable").Range("A3").Value

'This updates and refreshes the PIVOT table
With pt
Field.ClearAllFilters
Field.CurrentPage = NewCat
pt.RefreshTable
End With

End Sub

 

[Jerry Sullivan]

Hi SURFER349,

Am I correct in interpreting that anytime an item in Range("A2:A5") is changed, you want field "FilterColumnName" of PivotTable1 on the same worksheet filtered to show only those items in A2:A5?

What action would you want to happen if none of those items exist in the PivotTable?

 

[SURFER349]

Ideally, I'd like to make a front page dashboard type option. I've got a long list of maybe 100+ items, so a slicer isn't that feasible. I'd like the user to input two or three terms in cells A2, A3, A4, A5, etc..

• Maybe for simplicity, let's just assume two inputs in A2 and A3.
• Both of these inputs would then filter a PivotTable on another tabsheet, under the same filter header.
• Example, filtering by SalesRep name, user can input 2 different names and the PT then updates to only show both those names.
• This is NOT trying to filter a PT by two different field headers. This is filtering a single field by multiple selections.
• if the user inputs something that does not exist, maybe an error could pop up? Currently, I think it crashed the VBA code.

The next rev would then also to set these user inputs to update multiple PT's on various tabsheets.

I'm starting to think it might be easier to do this in JMP also. Currently, I'm importing csv data to hidden sheets using a dataconnection.

[COLOR=#333333]Private Sub Worksheet_SelectionChange(ByVal Target As Range)[/COLOR]

[COLOR=#333333]'This line stops the worksheet updating on every change, it only updates when cells are touched[/COLOR]
[COLOR=#333333]If Intersect(Target, Range("A2:A5")) Is Nothing Then Exit Sub[/COLOR]

[COLOR=#333333]'Set the Variables to be used[/COLOR]
[COLOR=#333333]Dim pt As PivotTable[/COLOR]
[COLOR=#333333]Dim Field As PivotField[/COLOR]
[COLOR=#333333]Dim NewCat As String[/COLOR]

[COLOR=#333333]'Here you amend to suit your data.  Assigns input cell value to the PT on another tab.[/COLOR]
[COLOR=#333333]Set pt = Worksheets("Tab that contains PivotTable").PivotTables("PivotTable1")[/COLOR]
[COLOR=#333333]Set Field = pt.PivotFields("FilterColumnName")[/COLOR]
[COLOR=#333333]NewCat = Worksheets("MainTab").Range("A3").Value[/COLOR]

[COLOR=#333333]'This updates and refreshes the PIVOT table[/COLOR]
[COLOR=#333333]With pt[/COLOR]
[COLOR=#333333]Field.ClearAllFilters[/COLOR]
[COLOR=#333333]Field.CurrentPage = NewCat[/COLOR]
[COLOR=#333333]pt.RefreshTable[/COLOR]
[COLOR=#333333]End With[/COLOR]

[COLOR=#333333]End Sub[/COLOR]

 

[SURFER349]

• This is NOT trying to filter a PT by two different field headers. This is filtering a single field by multiple selections.

Currently, I have this section of code repeated for multiple pivot tables, each one filtering a single value and then combining the results. Ideally, I'd like to have a single pivottable that can filter several values.

 

[Jerry Sullivan]

Here's some code you can try.

Paste this code into the Sheet Code module of the sheet that has your user input range at A2:A3.

Private Sub Worksheet_Change(ByVal Target As Range)
 Dim rFilterInput As Range
 Dim sErrMsg As String
 Dim wksPivots As Worksheet
 
 '-check if changed cell(s) are within pivotitem input range
 Set rFilterInput = Range("A2:A3")
 
 If Intersect(Target, rFilterInput) Is Nothing Then GoTo ExitProc
 
 'On Error GoTo ErrProc
 Application.EnableCancelKey = xlErrorHandler
 Application.EnableEvents = False
  
 '--identify sheet with pivottable
 Set wksPivots = ThisWorkbook.Sheets("Tab that contains PivotTable")
 
 '--call sub to filter pivot based on user inputs
 Call FilterPivotField( _
   pvf:=wksPivots.PivotTables("PivotTable1").PivotFields("FilterColumnName"), _
   vVisibleItems:=Application.Transpose(rFilterInput.Value))
 
ExitProc:
 On Error Resume Next
 Application.EnableEvents = True
 If Len(sErrMsg) Then MsgBox sErrMsg
 Exit Sub

ErrProc:
 sErrMsg = Err.Number & ": " & Err.Description
 Resume ExitProc

End Sub

Paste this code into a Standard Code module (like Module1)

Option Explicit

'--in a Standard Code Module

'--if set to True, will display msgbox warning if
'    no pivotitems matching criteria are found
Const mbDISPLAY_WARNINGS As Boolean = True


Public Sub FilterPivotField(ByVal pvf As PivotField, ByVal vVisibleItems As Variant)
   
'--filters the specified pivotfield to make visible only the items passed
'     in 1-D array vVisibleItems- if they exist as pivotitems.
'--uses a dictionary to store all non-missing pivotitems for that pivotfield
'     vVisibleItems that exist in dictionary are denoted by dictionary items that match
'     the corresponding keys.
'--attempts to optimize filtering based on number of items and
'     pivotfield orientation.

 Dim dctPviCaptions As Object
 Dim lNdx As Long, lVisibleItemCount As Long
 Dim sItem As String, sVisibleItem As String, sCaption As String
 Dim vKey As Variant
 
 If pvf.Orientation = xlHidden Then GoTo ExitProc
 If pvf.Orientation = xlDataField Then GoTo ExitProc
 
 Set dctPviCaptions = dctReadPivotItemsToDictionary(pvf:=pvf)
 dctPviCaptions.CompareMode = 1 'TextCompare
 
 '--validate vlist is array
 If Not IsArray(vVisibleItems) Then vVisibleItems = Array(vVisibleItems)
 
 For lNdx = LBound(vVisibleItems) To UBound(vVisibleItems)
   sItem = vVisibleItems(lNdx)
   If sItem = "(All)" Then
      lVisibleItemCount = -1
      Exit For
   ElseIf dctPviCaptions.Exists(sItem) Then
      '--mark to be made visible
      dctPviCaptions(sItem) = sItem
      sVisibleItem = sItem
      lVisibleItemCount = lVisibleItemCount + 1
   End If
 Next lNdx
   
 With pvf
   '--attempts to optimize filtering based on number of items and
   '     pivotfield orientation.
   Select Case True
      Case lVisibleItemCount = -1
         '---"(All)"
         .ClearAllFilters
         
      Case lVisibleItemCount = 0
         If mbDISPLAY_WARNINGS Then
         '--since no items match, alert user
            MsgBox "No records meet criteria for " & vbCr _
               & "PivotTable: " & .Parent.Name & vbCr _
               & "PivotField: " & .Name
         End If
      Case lVisibleItemCount = 1 And .Orientation = xlPageField
         .ClearAllFilters
         .CurrentPage = sVisibleItem
      
      Case Else '--multiple pagefield items or row/colummfield
         .Parent.ManualUpdate = False
         If (.Orientation = xlPageField) And _
            (.EnableMultiplePageItems = False) Then
            '--if changing to multiple page items, need to clearallfilters
            '  otherwise "(Multiple Items)" caption may not be displayed
            .ClearAllFilters
            .EnableMultiplePageItems = True
            '--step through each pivotitem, hide those not marked as visible
            For Each vKey In dctPviCaptions.Keys
               If Len(dctPviCaptions(vKey)) = 0 Then
                  .PivotItems(vKey).Visible = False
               End If
            Next vKey
         Else
            '--multiple pagefield items(filters not cleared) or row/colummfield
            '--ensure at least one visible item
            .PivotItems(sVisibleItem).Visible = True
            
            '--step through each pivotitem. only change visible state if needed
            For Each vKey In dctPviCaptions.Keys
               If (Len(dctPviCaptions(vKey)) = 0) = .PivotItems(vKey).Visible Then
                  .PivotItems(vKey).Visible = Not .PivotItems(vKey).Visible
               End If
            Next vKey
         End If
         .Parent.ManualUpdate = False
   End Select
 End With
 
ExitProc:
 
End Sub

Private Function dctReadPivotItemsToDictionary( _
   ByVal pvf As PivotField) As Object
   
'--returns a dictionary consisting of keys for each pivotitem caption
'     in the passed pivotfield.
'  blank pivot items are stored as the key "(blank)"
'  missing pivotitems (retained by filters) are not stored in dictionary

 Dim bCheckForMissingItems As Boolean
 Dim dctPviCaptions As Object
 Dim lItem As Long
 Dim sItem As String
  
 Set dctPviCaptions = CreateObject("Scripting.Dictionary")
 dctPviCaptions.CompareMode = 1 'TextCompare
 
 '--check if missing items might be in cache
 bCheckForMissingItems = pvf.Parent.PivotCache _
   .MissingItemsLimit <> xlMissingItemsNone
 
 For lItem = 1 To pvf.PivotItems.Count
   With pvf.PivotItems(lItem)
      Select Case True
         Case bCheckForMissingItems = False, .RecordCount
            sItem = dctPviCaptions.Item(.Caption)
         Case .Caption = "(blank)"
            sItem = dctPviCaptions.Item("(blank)")
         Case Else
            '--don't add to dictionary
      End Select
   End With
 Next lItem
 
 Set dctReadPivotItemsToDictionary = dctPviCaptions
End Function

 

[SURFER349]

awesome, this is working. So if I have multiple pivot tables on various tabs, I just keep referencing the new sub on the sheet code module?

 

[SURFER349]

Also, how could I edit this so the input cells are in a horizontal range, like in the Row1, frozen/locked so its always visible.

For example, input1@B1, input2@D2?

 

[SURFER349]

hmm...I seem to be having problems. It is hanging up on the private worksheet code, unable to even start the "Private Sub Worksheet_Change(ByVal Target As Range)"

How could I fix?

Also, any idea how to get it to use a horizontal list of inputs? The error check is nice, but honestly, I am having trouble following what is going on with it or how it works compared to the first Private Sub. Can you help with adjusting the privateSub script to use just the current refresh check I have and then call a module Sub to update pivottables w/ multiple filter items?

 

[Jerry Sullivan]

I've modified the code to handle either a vertical or horizontal list. Please replace the previous Worksheet_Change code with this. (the procedures in the Standard Code module don't need to be changed).

Private Sub Worksheet_Change(ByVal Target As Range)
 Dim rFilterInput As Range
 Dim sErrMsg As String
 Dim vVisibleItems As Variant
 Dim wksPivots As Worksheet
 
 '-check if changed cell(s) are within pivotitem input range
 Set rFilterInput = Range("A2:A4") 'can be one column vertical range OR
 
 Set rFilterInput = Range("A2:C2") 'one-row horizontal range

 If Intersect(Target, rFilterInput) Is Nothing Then GoTo ExitProc
 
 On Error GoTo ErrProc
 With Application
   .EnableCancelKey = xlErrorHandler
   .EnableEvents = False
   If rFilterInput.Columns.Count = 1 Then
      vVisibleItems = .Transpose(rFilterInput.Value)
   ElseIf rFilterInput.Rows.Count = 1 Then
      vVisibleItems = .Transpose(.Transpose(rFilterInput.Value))
   Else
      sErrMsg = "Filter item range must be one column or one row."
      GoTo ExitProc
   End If
 End With
 '--identify sheet with pivottable
 Set wksPivots = ThisWorkbook.Sheets("Tab that contains PivotTable")
 
 '--call sub to filter pivot based on user inputs
 Call FilterPivotField( _
   pvf:=wksPivots.PivotTables("PivotTable1").PivotFields("FilterColumnName"), _
   vVisibleItems:=vVisibleItems)
  
ExitProc:
 On Error Resume Next
 Application.EnableEvents = True
 If Len(sErrMsg) Then MsgBox sErrMsg
 Exit Sub

ErrProc:
 sErrMsg = Err.Number & ": " & Err.Description
 Resume ExitProc

End Sub

I had disabled the error handling in my Post #5 code. That is likely the reason that your events were not reset when you encountered an error. This code above has the error handling enabled.

 

[SURFER349]

most excellent. I think its all working well. !

One more question. From inside the worksheet auto-update code, how do I get it then call other subs from other modules? For example, I've got a module sub macro that I recorded that basically resizes and reformats and copy/pastes some info.