Table Filter to Set Pivot Table Field on a Different Worksheet

[paullrg]

Hi all, first time posting.

Using Excel 2010, I have a large Table on a tab called "Data - $" and a predefined pivot table on a different tab called "Gate Status". The goal is to refresh the pivot table and autofilter one of the pivot row fields based on the filter selected in the Table on the other sheet. This would occur anytime someone switches into the pivot table sheet.

The table filter (in this case called "Facility") will definitely have duplicates that need to be distilled down to just one unique instance of each label

After scouring the Net, I finally came across some code on this forum from Jerry Sullivan, that I adapted and it works.
https://www.mrexcel.com/forum/excel...off-multiple-reference-cells.html#post4766111

Even though my adaptation on the code is working, I'm thinking the solution I'm using is MUCH more complicated than it needs to be. Can you please review and let me know if there is a much more simple approach? I also stayed away from adapting a Slicer solution because of the real estate needed on the Table sheet - the table header filters are much more compact. But I did try building an array and passing that to Jerry's code, which I couldn't get to work.

Thanks in advance for your review and guidance.

Here's the code for kicking off the pivot table updates that is in the pivot table worksheet:

Private Sub Worksheet_Activate()
Dim rFilterInput As Range
Dim sErrMsg As String
Dim vVisibleItems As Variant
Dim wksPivots, wsData As Worksheet
Dim rng As Range

Set wsData = Worksheets("Data - $")
Set wksPivots = Worksheets("Gate Status")

With Application
    .ScreenUpdating = False
    .DisplayStatusBar = False
    .MultiThreadedCalculation.Enabled = True
    .Calculation = xlCalculationManual
End With

'Copy/Paste Facility info for Pivot table filter
wksPivots.PivotTables("GateStatus").PivotCache.Refresh
wsData.Range("Data[Facility]").SpecialCells(xlCellTypeVisible).Copy
wksPivots.Range("Z2").PasteSpecial Paste:=xlPasteValues
Set rng = wksPivots.Range("Z2").CurrentRegion
rng.RemoveDuplicates Columns:=1, Header:=xlNo
rng.Sort Key1:=wksPivots.Range("Z2"), _
        Order1:=xlAscending, Header:=xlNo
Set rng = wksPivots.Range("Z2").CurrentRegion
rng.Resize(rng.Rows.Count, 1).Name = "DataFacility"
Range("A7").Select

'Set parameters for sub to filter pivot table
Set rFilterInput = Range("DataFacility")
With Application
   .EnableCancelKey = xlErrorHandler
   .EnableEvents = False
   vVisibleItems = .Transpose(rFilterInput.Value)
End With
 
On Error GoTo ErrProc
 
'--call sub to filter pivot based on user inputs
Call FilterPivotField( _
    pvf:=wksPivots.PivotTables("GateStatus").PivotFields("Facility"), _
    vVisibleItems:=vVisibleItems)
 
ExitProc:
    On Error Resume Next
With Application
    .Calculation = xlCalculationAutomatic
    .EnableEvents = True
    .DisplayStatusBar = True
    .ScreenUpdating = True
End With
    If Len(sErrMsg) Then MsgBox sErrMsg
    Exit Sub

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

And here is the code that is in the Module (not that I understand much of it):

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