asked on

VBA – Set PivotItems based on a list of values

In VBA I would like to set the visible PivotItems based on a list of values. For example I have a list of employees that work for a specific manager. I would like to loop through all the "Name" Items in the Pivot Table and set the ones in the "employee list" to visible and hide the others. Sample file attached.

My code attempt fails to clear the last item in the table so I always end up with an extra name that should not be there.

Any assistance is appreciated.
Thanks,
Jerry

Sub Set_Manager_PivotItems()
    Dim PT As PivotTable
    Dim pf As PivotField
    Dim pi As PivotItem
    Application.ScreenUpdating = False

    Set PT = Sheets("EE Sample").PivotTables("PivotTable1")
    Set pf = PT.PivotFields("Name")

    PT.ManualUpdate = True

    On Error Resume Next
    For Each pi In pf.PivotItems
        pi.Visible = False
    Next

    With pf
        i = 1
        Do Until Range("EmpList").Offset(i, 0).Value = ""
            EmpName = Range("EmpList").Offset(i, 0)
            .PivotItems(EmpName).Visible = True
            i = i + 1
        Loop
    End With

    PT.ManualUpdate = False
    Application.ScreenUpdating = True

End Sub

Open in new window

EE-Pivot-Items-Sample.xlsm

nutsch

I have updated your name EmpList in the worksheet to
=OFFSET('EE Sample'!$H$3,1,0,COUNTA('EE Sample'!$H:$H)-1,1)

instead of
='EE Sample'!$H$3
so it takes all the name into consideration.

Then I have updated your code slightly

Sub Set_Manager_PivotItems()
    Dim PT As PivotTable
    Dim pf As PivotField
    Dim pi As PivotItem, lgMatch As Long
    Application.ScreenUpdating = False

    Set PT = Sheets("EE Sample").PivotTables("PivotTable1")
    Set pf = PT.PivotFields("Name")

    PT.ManualUpdate = True

    On Error Resume Next
    For Each pi In pf.PivotItems
        On Error Resume Next
        lgMatch = Application.Match(pi, Range("EmpList"), 0)
        If Err <> 0 Then
            pi.Visible = False
            Err.Clear
        Else
            pi.Visible = True
        End If
    Next

    PT.ManualUpdate = False
    Application.ScreenUpdating = True

End Sub

Open in new window

Thomas

nutsch

Actually, after further testing, my code doesn't solve your problem too well. This update should:

Sub Set_Manager_PivotItems()
    Dim PT As PivotTable
    Dim pf As PivotField
    Dim pi As PivotItem
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    Set PT = Sheets("EE Sample").PivotTables("PivotTable1")
    Set pf = PT.PivotFields("Name")

    PT.ManualUpdate = True

    On Error Resume Next
    For Each pi In pf.PivotItems
        pi.Visible = True
    Next pi
    
    For Each pi In pf.PivotItems
        If IsError(Application.Match(pi, Range("EmpList"), 0)) Then _
            pi.Visible = False
    Next

    PT.ManualUpdate = False
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
End Sub

Open in new window

Thomas

ASKER CERTIFIED SOLUTION