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
LVL 16
Jerry PaladinoAsked:
Who is Participating?
 
Rory ArchibaldCommented:
FWIW, you could also just set one of the matching items visible first, then loop through the others and set visibility as appropriate:
Sub Set_Manager_PivotItems()
   Dim PT As PivotTable
   Dim pf As PivotField
   Dim pi As PivotItem
   Dim rngEmps As Range
   Dim i As Long
   Application.ScreenUpdating = False

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

   ' get employee list
   Set rngEmps = Range("EmpList").CurrentRegion
   ' exclude header row
   Set rngEmps = rngEmps.Offset(1).Resize(rngEmps.Count - 1)

   PT.ManualUpdate = True
   On Error Resume Next
   For i = 1 To rngEmps.Count
      Set pi = pf.PivotItems(rngEmps.Cells(i).Value)
      If Not pi Is Nothing Then Exit For
   Next i
   If pi Is Nothing Then
      MsgBox "No matching employees!"
   Else
      pi.Visible = True
      For Each pi In pf.PivotItems
         pi.Visible = Not IsError(Application.Match(pi.Name, rngEmps, 0))
      Next pi
   End If
   PT.ManualUpdate = False
   Application.ScreenUpdating = True

End Sub

Open in new window

0
 
nutschCommented:
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
0
 
nutschCommented:
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
0
Free Tool: IP Lookup

Get more info about an IP address or domain name, such as organization, abuse contacts and geolocation.

One of a set of tools we are providing to everyone as a way of saying thank you for being a part of the community.

 
Jerry PaladinoAuthor Commented:
Rory - Thank you.
0
 
Rory ArchibaldCommented:
Did Thomas' second code not worl? (I didn't test) If it did, then points to him, I think. :)
0
 
Jerry PaladinoAuthor Commented:
Thomas - Thank you as well.  I appreciate your time.  The second post was leaving just the last entry from the data table. "Chris"
0
Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

All Courses

From novice to tech pro — start learning today.