Option Explicit
Sub FilterPivot()
' Description: Wrapper function for my FilterPivot Function
' (Required in the event that a user wants to trigger the FilterPivot
' function and specify parameters at runtime, instead of programatiacally
' calling the routine)
' Programmer: Jeff Weir
' Contact: weir.jeff@gmail.com or jeff.weir@HeavyDutyDecisions.co.nz
' Name/Version: Date: Ini: Modification:
' FilterPivot 20150305 JSW Initial programming
FilterPivot_Routine
End Sub
Sub FilterPivot_Invert()
' Description: Wrapper function for my FilterPivot_Inverse Function
' Inverts the current selection
' (Required in the event that a user wants to trigger the FilterPivot_Inverse
' function and specify parameters at runtime, instead of programatiacally
' calling the routine)
' Programmer: Jeff Weir
' Contact: weir.jeff@gmail.com or jeff.weir@HeavyDutyDecisions.co.nz
' Name/Version: Date: Ini: Modification:
' FilterPivot_Inverse 20150305 JSW Initial programming
FilterPivot_Routine ActiveCell.PivotField.DataRange, ActiveCell.PivotField.DataRange, bInverse:=True
End Sub
Sub FilterPivot_Inverse()
' Description: Wrapper function for my FilterPivot_Inverse Function
' (Required in the event that a user wants to trigger the FilterPivot_Inverse
' function and specify parameters at runtime, instead of programatiacally
' calling the routine)
' Programmer: Jeff Weir
' Contact: weir.jeff@gmail.com or jeff.weir@HeavyDutyDecisions.co.nz
' Name/Version: Date: Ini: Modification:
' FilterPivot_Inverse 20150305 JSW Initial programming
FilterPivot_Routine bInverse:=True
End Sub
Private Sub FilterPivot_AddRightClick()
' Description: Adds "Filter Pivotfield" shortcuts to PivotTable right-click menu
' Programmer: Jeff Weir
' Contact: weir.jeff@gmail.com or jeff.weir@HeavyDutyDecisions.co.nz
' Name/Version: Date: Ini: Modification:
' AddShortcuts 20150305 JSW Initial programming
Dim cbr As CommandBar
Dim sMessage As String
Set cbr = Application.CommandBars("PivotTable Context Menu")
With cbr.Controls.Add(Type:=msoControlButton, Temporary:=True)
.Caption = "Filter Pivotfield"
.Tag = "FilterPivotField"
.OnAction = "FilterPivot"
.Style = msoButtonIconAndCaption
.Picture = Application.CommandBars.GetImageMso("FilterAdvancedByForm", 16, 16)
End With
With cbr.Controls.Add(Type:=msoControlButton, Temporary:=True)
.Caption = "Inversely Filter Pivotfield"
.Tag = "FilterPivotField"
.OnAction = "FilterPivot_Inverse"
.Style = msoButtonIconAndCaption
.Picture = Application.CommandBars.GetImageMso("FilterAdvancedMenu", 16, 16)
End With
sMessage = "Cool, I've added an option for you to trigger this code by right-clicking "
sMessage = sMessage & "the PivotTable field that you want to filter."
sMessage = sMessage & vbNewLine & vbNewLine & "Happy filtering!"
MsgBox sMessage, vbOKOnly, "Right-click options added..."
End Sub
Private Sub FilterPivot_RemoveRightClick()
' Description: Removes "Filter Pivotfield" shortcuts from PivotTable right-click menu
' Programmer: Jeff Weir
' Contact: weir.jeff@gmail.com or jeff.weir@HeavyDutyDecisions.co.nz
' Name/Version: Date: Ini: Modification:
' AddShortcuts 20150305 JSW Initial programming
Dim cbr As CommandBar
Dim sMessage As String
Dim ctrl As CommandBarControl
Set cbr = Application.CommandBars("PivotTable Context Menu")
For Each ctrl In cbr.Controls
If ctrl.Tag = "FilterPivotField" Then ctrl.Delete
Next
sMessage = "Cool, I've removed the RightClick options for the FilterPivot routines."
MsgBox sMessage, vbOKOnly, "Right-click options added..."
End Sub
Private Function FilterPivot_Slicers(ptTemp As PivotTable, pfTemp As PivotField, ptOriginal As PivotTable)
Dim sc As SlicerCache
' This sub-function contains code that requires Slicers
' It's in this stand-alone function, becaues it only gets called if user has Excel 2010 or later
' If it was incorporated DIRECTY within the FilterPivot function, that function wouldn't compile on pre 2010 machines
Set sc = ActiveWorkbook.SlicerCaches.Add(ptTemp, pfTemp)
sc.PivotTables.AddPivotTable ptOriginal
'Great, our original pivot now just has one item visible in the field of interest
'So we can delete the slicer connection
sc.Delete
End Function
Private Function FilterPivot_Routine(Optional rngPivotField As Range, Optional rngFilterItems As Range, Optional bInverse As Boolean = False) As Boolean
' Copyright ©2013 Jeff Weir
' weir.jeff@gmail.com
' You are free to use this code within your own applications, add-ins,
' documents etc but you are expressly forbidden from selling or
' otherwise distributing this source code without prior consent.
' This includes both posting free demo projects made from this
' code as well as reproducing the code in text or html format.
' ---------------------------------------------------------------------
' Date Initial Version Details
' 20131113 JSW 007 Initial Programming
' 20131203 JSW 008 Added Inverse Option
' 20140503 JSW 009 Changed so works in pre Excel 2010
' 20140503 JSW 010 Changed so pi.format check not performed in Excel 2013 +
' 20150223 JSW 011 Added check to ensure pfOriginal has .EnableMultiplePageItems set to TRUE if it is a pagefield.
' 20150429 JSW 012 Turned off events, cleared pfOriginal filter.
'#############
'# Remarks #
'#############
' This code needs to be called by a wrapper function.
' e.g.
' Sub FilterPivot()
' FilterPivot_Routine
' End Sub
' Sub FilterPivot_Inverse()
' FilterPivot_Routine bInverse:=True
' End Sub
' If required, that wrapper function can also provide ranges
' specifying what PivotField to filter, and where the range of
' filter terms is. e.g.:
' FilterPivot_Routine Range("A2"), Range("C2:C20000")
' ...or
' FilterPivot_Routine ActiveCell, [tblFilterItems]
Dim ptOriginal As PivotTable
Dim ptTemp As PivotTable
Dim pfOriginal As PivotField
Dim pfTemp As PivotField
Dim pfFilterItems As PivotField
Dim lngFilterItems As Long
Dim pi As PivotItem
Dim ptFilterItems As PivotTable
Dim wksTemp As Worksheet
Dim wksPivot As Worksheet
Dim dic As Object
Dim varContinue As Variant
Dim strMessage As String
Dim varFormat As Variant
Dim bDateFormat As Boolean
Dim bDateWarning As Boolean
Dim bFirstItemVisible As Boolean
Dim varFirstItemVisible As Variant
FilterPivot_Routine = False 'Assume failure
On Error GoTo errhandler
Set wksPivot = ActiveSheet
'If neccessary, prompt user for the pivotfield of interest
If rngPivotField Is Nothing Then
On Error Resume Next
Set rngPivotField = ActiveCell
Set pfOriginal = rngPivotField.PivotField 'Tests if this is in fact a PivotField
If Err <> 0 Then
Err.Clear
Set rngPivotField = Nothing
Set rngPivotField = Application.InputBox( _
Title:="Where is the PivotField?", _
Prompt:="Please select a cell in the PivotField you want to filter", _
Type:=8)
On Error GoTo errhandler
If rngPivotField Is Nothing Then Err.Raise 996
End If
On Error GoTo errhandler
End If
Set pfOriginal = rngPivotField.PivotField
Set ptOriginal = pfOriginal.Parent
With pfOriginal
If .Orientation = xlPageField Then
If .EnableMultiplePageItems = False Then
.EnableMultiplePageItems = True
.ClearAllFilters
End If
End If
End With
'If neccessary, prompt user for FilterItems table related to the pivotfield of interest
If rngFilterItems Is Nothing Then
On Error Resume Next
Set rngFilterItems = Application.InputBox( _
Title:="Where are the filter items?", _
Prompt:="Please select the range where your filter terms are.", _
Type:=8)
On Error GoTo errhandler
If rngFilterItems Is Nothing Then Err.Raise 996
End If
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
.EnableEvents = False
End With
' Excel stores dates differently between PivotItems and Variant Arrays.
' For instance:
' ? CStr(varFilterItems(i, 1))
' 1/01/2013
' ? pi.Value
' 1/1/2013
' ? CStr(varFilterItems(i, 1)) = pi.Value
' False
'So we 'll turn our FilterItems into a PivotTable to ensure formats are treated the same.
Set wksTemp = Sheets.Add
rngFilterItems.Copy wksTemp.Range("A2")
wksTemp.Range("A1").Value = "FilterItems"
Set rngFilterItems = wksTemp.Range("A2").CurrentRegion
On Error GoTo errhandler
ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:= _
rngFilterItems).CreatePivotTable _
TableDestination:=[C1], TableName:="appFilterItems"
Set ptFilterItems = wksTemp.PivotTables("appFilterItems")
Set pfFilterItems = ptFilterItems.PivotFields(1)
' Add FILTERItems to a Dictionary
Set dic = CreateObject("scripting.dictionary")
For Each pi In pfFilterItems.PivotItems
dic.Add pi.Value, 1 'The one does nothing
Next
ptOriginal.ManualUpdate = True 'dramatically speeds up the routine, because the pivot won't recalculate until we're done
'Check if PFOriginal is formatted as a date field.
' Basically there is a bug in Excel whereby if you try to do some things
' to a PivotItem containing a date but the PivotField number format is NOT a date format
' then you get an error.
' So we'll check the PivotField date format and see what it is
' Note that if a PivotField is based on a range that contains multiple formats
' then you get an error simply by checking what the PivotField number format is.
' So we'll instigate an On Error Resume Next to handle this
On Error Resume Next
varFormat = pfOriginal.NumberFormat
On Error GoTo errhandler
If IsDate(Format(1, varFormat)) Then bDateFormat = True
If bInverse Then
lngFilterItems = pfOriginal.PivotItems.Count - rngFilterItems.Count
Else: lngFilterItems = rngFilterItems.Count
End If
If lngFilterItems / pfOriginal.PivotItems.Count < 0.5 And Application.Version >= 14 Then
'====================================================================================
' If it's likely that less than half of the source Pivot Field's
' items will be visible when we're done, then it will be quickest to hide all but one
' item and then unhide the PivotItems that match the filter terms
' Iterating through a large pivot setting all but one item to hidden is slow.
' And there's no way to directly do this except in Page Fields, and
' that method doesn't let you select multiple items anyway.
' Plus, as soon as you drag a page field with just one item showing to
' a row field, Excel clears the filter, so that all items are visible again.
' So we'll use a trick:
' * make the pf of interest in ptTemp a page field
' * turn off multiple items and select just one PivotItem
' * connect it to the original pivot with a slicer
' This will very quickly sync up the field on the original pivot so that only one field is showing.
' NOTE: WE CAN ONLY DO THIS IF USING EXCEL 2010 OR LATER using the below approach.
' If earlier version, we'll use the approach outlined in the ELSE part of this IF block.
' ALSO NOTE: If a PivotField has a non-Date format, but contains dates, then
' we can't programatically hide/show items. So we need to check for this.
'====================================================================================
'Identify a suitable item with which to filter the original PivotTable with
' As per note above,
' * If the PivotField format is NOT a date format,
' then we need to make sure that this first item is NOT a date.
' ...because otherwise we can't address it by VBA
' * If the PivotFied format IS a date format, then just use the first item.
' * We'll write that item to a range, then to a variant, so that Excel applies the
' same format to it as it does to items in our Filter list
If Not bDateFormat Then
For Each pi In pfOriginal.PivotItems
If IsDate(pi.Value) Then
If IsNumeric(pi.Value) Then
'We need the IsNumeric bit above because
'VBA thinks that some decimals encased in strings e.g. "1.1" are dates
'So we need to check whether this is a decimal and NOT a date
varFirstItemVisible = pi.Value
Exit For
Else:
If Not bDateWarning Then
Err.Raise Number:=997, Description:="Can't filter dates"
End If
End If
Else:
varFirstItemVisible = pi.Value
Exit For
End If
Next
Else:
varFirstItemVisible = pfOriginal.PivotItems(1).Value
End If
Set ptTemp = ptOriginal.PivotCache.CreatePivotTable(TableDestination:=wksTemp.Range("F1"))
Set pfTemp = ptTemp.PivotFields(pfOriginal.SourceName)
With pfTemp
.Orientation = xlPageField
.ClearAllFilters
.EnableMultiplePageItems = False
.CurrentPage = pfTemp.PivotItems(varFirstItemVisible).Value
End With
Call FilterPivot_Slicers(ptTemp, pfTemp, ptOriginal)
' Check if FirstItemVisible should be visible or hidden when we are done
If dic.Exists(varFirstItemVisible) Then bFirstItemVisible = True
' Now try and add the PivotItems.
' If there's an error, we'll know that this item is also in the FilterTerms
On Error Resume Next
With dic
'The Not bInverse bit in the code blocks below effectively 'flip' the test "If Err.Number <> 0" to "If Err.Number = 0"
'in the case that bInverse argument is TRUE (meaning we want the Pivot to be filtered on things
' NOT in the list of search terms)
If Application.Version >= 15 Then
For Each pi In pfOriginal.PivotItems
dic.Add pi.Value, 1 'The 1 does nothing
If Err.Number <> 0 = Not bInverse Then
pi.Visible = True
End If
Err.Clear
Next
Else: 'There's a bug in previous versions where you can't use .Visible for dates
'if the PivotField is set to General format.
For Each pi In pfOriginal.PivotItems
dic.Add pi.Value, 1 'The 1 does nothing
If Err.Number <> 0 = Not bInverse Then
' This item exists in our search term list, so we should unhide it
' Note that due to a bug in Excel 2010, if this item is a date
' but the PivotField format is NOT a date format, we can't
' programatically hide/show items, so we'll have to check this first
If Not bDateFormat Then
If Not IsNumeric(pi.Value) Then
'We need the Not IsNumeric bit above because VBA thinks that
' some decimals encased in strings e.g."1.1" are dates
If IsDate(pi.Value) Then
If Not bDateWarning Then
On Error GoTo errhandler
Err.Raise Number:=997, Description:="Can't filter dates"
On Error Resume Next
End If
Else: pi.Visible = True
End If
Else: pi.Visible = True
End If
Else: pi.Visible = True
End If
End If
Err.Clear
Next
End If 'If Application.Version >= 15 Then
End With
If Not bFirstItemVisible = Not bInverse Then
pfOriginal.PivotItems(varFirstItemVisible).Visible = False
If Err.Number <> 0 Then
MsgBox "None of the filter items were found in the Pivot"
pfOriginal.ClearAllFilters
Err.Clear
End If
End If
Else:
' If it's likely that MORE than half of the source Pivot Field's items will be visible
' when we're done, then it's quickest to unhide all PivotItems and then hide the
' PivotItems that DON'T match the filter terms
pfOriginal.ClearAllFilters
' Now try and add the PivotItems.
' If there's an error, we'll know that this item is in the FilterItems
' Otherwise we'll hide it
On Error Resume Next
With dic
If Application.Version >= 15 Then
For Each pi In pfOriginal.PivotItems
dic.Add pi.Value, 1 'The 1 does nothing
If Err.Number = 0 = Not bInverse Then pi.Visible = False
Err.Clear
Next
Else:
For Each pi In pfOriginal.PivotItems
dic.Add pi.Value, 1 'The 1 does nothing
If Err.Number = 0 = Not bInverse Then
'The Not bInverse bit effectively 'flips' the test "If Err.Number = 0" to "If Err.Number <> 0"
'in the case that bInverse argument is TRUE (meaning we want the Pivot to be filtered on things
' NOT in the list of search terms)
'This PivotItem NOT in FilterItems list. So hide it
'Note that IF this item is a date but the PivotField format is NOT a date format,
' then we can't programatically hide/show items, so we'll have to check this first
If Not bDateFormat Then
If Not IsNumeric(pi.Value) Then
'We need the Not IsNumeric bit above because VBA thinks that some decimals encased in strings e.g."1.1" are dates
If IsDate(pi.Value) Then
If Not bDateWarning Then
On Error GoTo errhandler
Err.Raise Number:=997, Description:="Can't filter dates"
On Error Resume Next
End If
Else: pi.Visible = False 'This item does not exist in the FilterItems. So hide it
End If
Else: pi.Visible = False 'This item does not exist in the FilterItems. So hide it
End If
Else: pi.Visible = False
End If
End If
Err.Clear
Next
End If 'If Application.Version >= 15 Then
End With
End If 'If lngFilterItems / pfOriginal.PivotItems.Count < 0.5 And Application.Version >= 14 Then
On Error GoTo errhandler
FilterPivot_Routine = True
errhandler:
If Err.Number <> 0 Then
Select Case Err.Number
Case Is = 0: 'No error - do nothing
Case Is = 996: 'Operation Cancelled
Case Is = 997: 'Can't filter dates
strMessage = "*** WARNING...I can't correctly filter dates in this Pivot ***"
strMessage = strMessage & vbNewLine & vbNewLine
strMessage = strMessage & "I've found at least one date in this PivotField. "
strMessage = strMessage & "Unfortunately due to a bug in Excel, if you have dates "
strMessage = strMessage & " in a PivotField AND that PivotField is NOT formatted "
strMessage = strMessage & " with a date format, then dates "
strMessage = strMessage & " can't be programatically filtered either in or out. "
strMessage = strMessage & vbNewLine & vbNewLine
strMessage = strMessage & " So you'll have to manually check to see whether "
strMessage = strMessage & " date items appear as they should."
strMessage = strMessage & vbNewLine & vbNewLine
strMessage = strMessage & "Do you want me to continue anyway? "
varContinue = MsgBox(Prompt:=strMessage, Buttons:=vbYesNo, Title:="Sorry, can't filter dates")
If varContinue = 6 Then
bDateWarning = True
Resume Next
Else: pfOriginal.ClearAllFilters
End If
Case Is = 998: 'Can't filter Datafields
MsgBox "Oops, you can't filter a DataField." & vbNewLine & vbNewLine & "Please select a RowField, ColumnField, or PageField and try again.", vbCritical, "Can't filter Datafields"
Case Is = 999: 'no pivotfield selected
MsgBox "Oops, you haven't selected a pivotfield." & vbNewLine & vbNewLine & "Please select a RowField, ColumnField, or PageField and try again.", vbCritical, "No PivotField selected"
Case Else:
MsgBox "Whoops, something went wrong"
End Select
End If
With Application
If Not wksTemp Is Nothing Then
.DisplayAlerts = False
wksTemp.Delete
.DisplayAlerts = True
End If
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
.EnableEvents = True
End With
If Not ptOriginal Is Nothing Then ptOriginal.ManualUpdate = False
End Function