• Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  • When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

Change Pvt Table Filter based on a value in another cell

D

Dokat

Member
Hi,

I am trying to change pivot table geography field based on the selection in cell b4 in Summary tab. Its a drop down table. I am using below code however it is not working.

Can someone please help.

Code: 
Private Sub Worksheet_Change2(ByVal Target As Range)
    Dim xPTable As PivotTable
    Dim xPFile As PivotField
    Dim xStr As String
    On Error Resume Next
    If Intersect(Target, Worksheets("Summary").Range("B4").Value) Is Nothing Then Exit Sub
    Application.ScreenUpdating = False
    Set xPTable = Worksheets("Source Data").PivotTables("PivotTable1")
    Set xPFile = xPTable.PivotFields("Geography")
    xStr = Target.Text
    xPFile.ClearAllFilters
    xPFile.CurrentPage = xStr
    Application.ScreenUpdating = True
End Sub
 
First thing - I am not sure if it's a typo in your code Worksheet_Change2 is not a worksheet event. Need to change it to Worksheet_Change.

Try this:
Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
Dim xPTable As PivotTable
Dim xPFile As PivotField
Dim xStr As String

On Error Resume Next
If Intersect(Target, Target.Worksheet.Range("B4")) Is Nothing Then Exit Sub
Application.ScreenUpdating = False
Set xPTable = Worksheets("Source Data").PivotTables("PivotTable1")
Set xPFile = xPTable.PivotFields("Geography")
xStr = Target.Value
With xPFile
    .ClearAllFilters
    .PivotFilters.Add2 xlCaptionEquals, Value1:=xStr
End With
Application.ScreenUpdating = True
End Sub

This code is working for me so if this does not work for you, pls upload a sample file.

BR, Ajesh
 
Last edited:
Hi Ajesh,

Thank you for your response. "Worksheet_Change2" is not a typo...I already have an "Worksheet_Change" event in the module thats why i called Worksheet_Change2. Is there a way to merge to macros?

Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
   
    Dim R1 As Range, R2 As Range, R6 As Range, R3 As Range, R4 As Range, R5 As Range
    Set R1 = Range("CG1")
    Set R2 = Range("CF1")
    Set R6 = Range("CH1")
    Set R3 = Range("E2")
    Set R4 = Range("D2")
    Set R5 = Range("F2")
   
   
    If R1.Value = 1 Then R3.Interior.Color = vbWhite
       
    If R1.Value = 0 Then R3.Interior.Color = 6
       
    If R6.Value = 1 Then R5.Interior.Color = vbWhite
       
    If R6.Value = 0 Then R5.Interior.Color = 6
       
    If R2.Value = 1 Then R4.Interior.Color = vbWhite
   
    If R2.Value = 0 Then R4.Interior.Color = 6
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
Dim xPTable As PivotTable
Dim xPFile As PivotField
Dim xStr As String
On Error Resume Next
If Intersect(Target, Target.Worksheet.Range("B4")) Is Nothing Then Exit Sub
Application.ScreenUpdating = False
Set xPTable = Worksheets("Source Data").PivotTables("PivotTable1")
Set xPFile = xPTable.PivotFields("Geography")
xStr = Target.Value
With xPFile
    .ClearAllFilters
    .PivotFilters.Add2 xlCaptionEquals, Value1:=xStr
End With
Application.ScreenUpdating = True
End Sub
 
Not tested as no sample file but this should work:

Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
Dim xPTable As PivotTable
Dim xPFile As PivotField
Dim xStr As String
Dim tRng As Range

On Error Resume Next

Set tRng = Application.Union(Range("CG1"), _
                            Range("CF1"), _
                            Range("CH1"), _
                            Range("B4"))
If Intersect(Target, tRng) Is Nothing Then Exit Sub
    Select Case Replace(Target.Address, "$", "")
        Case "CF1"
            If Target.Value = 0 Then
                Range("D2").Interior.Color = 6
            ElseIf Target.Value = 1 Then
                Range("D2").Interior.Color = vbWhite
            End If
        Case "CG1"
            If Target.Value = 0 Then
                Range("E2").Interior.Color = 6
            ElseIf Target.Value = 1 Then
                Range("E2").Interior.Color = vbWhite
            End If
        Case "CH1"
            If Target.Value = 0 Then
                Range("F2").Interior.Color = 6
            ElseIf Target.Value = 1 Then
                Range("F2").Interior.Color = vbWhite
            End If
        Case "B4"
            Application.ScreenUpdating = False
            Set xPTable = Worksheets("Source Data").PivotTables("PivotTable1")
            Set xPFile = xPTable.PivotFields("Geography")
            xStr = Target.Value
            With xPFile
                .ClearAllFilters
                .PivotFilters.Add2 xlCaptionEquals, Value1:=xStr
            End With
            Application.ScreenUpdating = True
    End Select
End Sub
 
Thanks i modified the code little bit and the first code is working however i can't get second filter to work.
Cell B4 filter the pivottable1 geography field but a4 doesnt filter for field "% Dollar Sales by Merch Any Price Reduction" in the same pivot table. Can you please help.

Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
  
    Dim R1 As Range, R2 As Range, R6 As Range, R3 As Range, R4 As Range, R5 As Range
    Set R1 = Range("CG1")
    Set R2 = Range("CF1")
    Set R6 = Range("CH1")
    Set R3 = Range("E2")
    Set R4 = Range("D2")
    Set R5 = Range("F2")
  
  
    If R1.Value = 1 Then R3.Interior.Color = vbWhite
      
    If R1.Value = 0 Then R3.Interior.Color = 6
      
    If R6.Value = 1 Then R5.Interior.Color = vbWhite
      
    If R6.Value = 0 Then R5.Interior.Color = 6
      
    If R2.Value = 1 Then R4.Interior.Color = vbWhite
  
    If R2.Value = 0 Then R4.Interior.Color = 6

Dim xPTable As PivotTable
Dim xPFile As PivotField
Dim xStr As String

On Error Resume Next
If Intersect(Target, Target.Worksheet.Range("B4")) Is Nothing Then Exit Sub
Application.ScreenUpdating = False
Set xPTable = Worksheets("Source Data").PivotTables("PivotTable1")
Set xPFile = xPTable.PivotFields("Geography")
xStr = Target.Value
With xPFile
    .ClearAllFilters
    .PivotFilters.Add2 xlCaptionEquals, Value1:=xStr
End With
Application.ScreenUpdating = True

If Intersect(Target, Target.Worksheet.Range("A4")) Is Nothing Then Exit Sub
Application.ScreenUpdating = False
Set xPTable = Worksheets("Source Data").PivotTables("PivotTable1")
Set xPFile = xPTable.PivotFields("% Dollar Sales by Merch Any Price Reduction")
xStr = Target.Value
With xPFile
    .ClearAllFilters
    .PivotFilters.Add2 xlCaptionEquals, Value1:=xStr
End With
Application.ScreenUpdating = True

End Sub


Ajesh said:
Not tested as no sample file but this should work:

Code: 
Private Sub Worksheet_Change(ByVal Target As Range)

            Application.ScreenUpdating = False
            Set xPTable = Worksheets("Source Data").PivotTables("PivotTable1")
            Set xPFile = xPTable.PivotFields("Geography")
            xStr = Target.Value
            With xPFile
                .ClearAllFilters
                .PivotFilters.Add2 xlCaptionEquals, Value1:=xStr
            End With
            Application.ScreenUpdating = True
    End Select
End Sub
Click to expand...
 
Dokat, you need to provide a sample file if you need a robust solution. What I see in your code is that you are cheery picking the parts and trying to incorporate in your own code which may not work always. There are n number of factors due to which one thing works and another don't. Working on assumptions is always a waste of time for both of us.

Did you try my code (as a whole) provided in #4 reply? That is much easier to customize and add extra target cells with different actions. All you need to do is add the target cells in tRng and relevant action code in Select case.

BR/Ajesh
 
You must log in or register to reply here.
Back
Top