The code below uses an input box to collect the users criteria so they can quickly and easily hide pivot table field items by a criteria they specify.
The raw data that the Pivot Table is based on is 3 columns consisting of the Fields:
Department (Row Field)
Employee (Row Field & Data Field)
Age (Row Field & Data Field. Also the items that are hidden by criteria)
Sub HideByCriteria() 'Declare variables 'SEE: http://www.ozgrid.com/VBA/variables.htm 'SEE: http://www.ozgrid.com/VBA/variable-scope-lifetime.htm Dim pt As PivotTable, pi As PivotItem Dim lAge As Long Dim strCri As String, strCri1 As String, strCri2 As String Dim bHide As Boolean Dim xlCalc As XlCalculation Set pt = Sheet4.PivotTables("PivotTable1") 'SEE: http://www.ozgrid.com/Excel/excel-pivot-tables.htm strCri = InputBox("Enter your criteria for hiding employees by age." _ & Chr(13) & "Valid Criteria Examples:" _ & Chr(13) & "'>20' for ages above 20." _ & Chr(13) & "'>=30 <40' for ages equal to or above 30 but below 40.", "HIDE AGE") 'SEE: http://www.ozgrid.com/VBA/inputbox.htm 'They Cancelled. If strCri = vbNullString Then Exit Sub 'Remove any *excess* spacing strCri = Trim(strCri) 'Speed up code. 'SEE: http://www.ozgrid.com/VBA/SpeedingUpVBACode.htm 'SEE: http://www.ozgrid.com/VBA/calc-stop.htm 'Set PT to manual update. pt.ManualUpdate = True 'SEE: http://www.ozgrid.com/VBA/pivot-table-fields.htm 'Get users calculation mode, go to manual & stop screen updating With Application xlCalc = .Calculation .Calculation = xlCalculationManual '.ScreenUpdating = False End With 'Error trap for non valid criteria On Error GoTo NonValidCriteria: 'SEE: http://www.ozgrid.com/VBA/ExcelVBAErrors.htm 'Find out if between or single criteria. If InStr(1, strCri, " ") = 0 Then 'Single For Each pi In pt.PivotFields("Age").PivotItems 'SEE: http://www.ozgrid.com/VBA/loops.htm 'SEE: http://www.ozgrid.com/VBA/VBALoops.htm lAge = pi bHide = Evaluate(lAge & strCri) pi.Visible = bHide Next pi Else 'Between 'Get 1st criteria strCri1 = Mid(strCri, 1, InStr(1, strCri, " ") - 1) 'Get 2nd criteria strCri2 = Mid(strCri, InStr(1, strCri, " ") + 1, 256) For Each pi In pt.PivotFields("Age").PivotItems lAge = pi bHide = Evaluate(lAge & strCri1) And Evaluate(lAge & strCri2) pi.Visible = bHide Next pi End If pt.ManualUpdate = False With Application .Calculation = xlCalc .ScreenUpdating = True End With Exit Sub NonValidCriteria: MsgBox "Your criteria is not valid", vbCritical pt.ManualUpdate = False With Application .Calculation = xlCalc .ScreenUpdating = True End With End Sub
Sub ShowAll() Dim pt As PivotTable, pi As PivotItem Dim xlCalc As XlCalculation Set pt = Sheet4.PivotTables("PivotTable1") pt.ManualUpdate = True With Application xlCalc = .Calculation .Calculation = xlCalculationManual .ScreenUpdating = False ' End With On Error Resume Next For Each pi In pt.PivotFields("Age").PivotItems pi.Visible = True Next pi On Error GoTo 0 pt.ManualUpdate = False With Application .Calculation = xlCalc .ScreenUpdating = True End With End Sub
See also Index to Excel VBA Code and Index to Excel Freebies and Lesson 1 - Excel Fundamentals and Index to how to… providing a range of solutions.
Click here to visit our Free 24/7 Excel/VBA Help Forum where there are thousands of posts you can get information from, or you can join the Forum and post your own questions.