VBA code to select multiple items on pivot table

Hi, I need a help to create a vba code for following task.

I have 2 pivot tables. pivot table 1 showing the parent unit and component list.

Second Pivot table showing the details of revenue, production information for the component list.

what i need is when the user to key in the parent unit desired,
a. pivot table 1 will show the parent unit desired and its component list
b. pivot table 2 will show the details base on component list from pivot table 1.

I create a simple excel, can anyone help ? i'm a bit stuck. the actual report that i need contain a thousands of line item, and one parent unit can have as much as 50 component, so to do it manually is not preferable.
sample.xlsx
Sindharta WierawanData Analyst Asked:
Who is Participating?

[Product update] Infrastructure Analysis Tool is now available with Business Accounts.Learn More

x
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

Subodh Tiwari (Neeraj)Excel & VBA ExpertCommented:
You may try something like this...

Place the following code on Sheet1 Module for Sheet Change Event. So when you change the Unit in K9, both the Pivot Tables will be filtered accordingly.


Private Sub Worksheet_Change(ByVal Target As Range)
If Target.CountLarge > 1 Then Exit Sub
Dim pt1 As PivotTable, pt2 As PivotTable
Dim pf As PivotField, pi As PivotItem
Dim x, Items()
Dim i As Long, j As Long

On Error Resume Next
Set pt1 = ActiveSheet.PivotTables("PivotTable1")
Set pt2 = ActiveSheet.PivotTables("PivotTable2")
On Error GoTo 0

If pt1 Is Nothing Or pt2 Is Nothing Then
    MsgBox "PivotTable not found.", vbCritical
    Exit Sub
End If

If Target.Address(0, 0) = "K9" Then
    x = Range("B3").CurrentRegion.Value
    If Target <> "" Then
        
        If Not IsError(Application.Match(Target.Value, Application.Index(x, 0, 1), 0)) Then
            For i = 2 To UBound(x, 1)
                If LCase(x(i, 1)) = LCase(Target.Value) Then
                    j = j + 1
                    ReDim Preserve Items(1 To j)
                    Items(j) = x(i, 2)
                End If
            Next i
            Set pf = pt1.PivotFields("Unit")
            pf.ClearAllFilters
            For Each pi In pf.PivotItems
                If LCase(pi.Name) <> LCase(Target.Value) Then
                    pi.Visible = False
                End If
            Next pi
            
            Set pf = pt2.PivotFields("Item")
            pf.ClearAllFilters
            For Each pi In pf.PivotItems
                If IsError(Application.Match(pi.Name, Items, 0)) Then
                    pi.Visible = False
                End If
            Next pi
        Else
            MsgBox "Unit not found!", vbExclamation
            Exit Sub
        End If
    Else
        On Error Resume Next
        For Each pf In pt1.PivotFields
            pf.ClearAllFilters
        Next pf
        For Each pf In pt2.PivotFields
            pf.ClearAllFilters
        Next pf
    End If
End If
End Sub

Open in new window

PivotTableSample.xlsm
0

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
Sindharta WierawanData Analyst Author Commented:
Thanks a lot for your help....the code is working...I really appreciate your help...
0
Subodh Tiwari (Neeraj)Excel & VBA ExpertCommented:
You're welcome Sindharta! Glad it worked as desired.
0
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
Microsoft Office

From novice to tech pro — start learning today.