I wrote a block of code that checks if cell C2 has changed and uses it's value as the filter for a column in a pivot table
Private Sub Worksheet_Change(ByVal Target As Range)
Dim xPTable As PivotTable
Dim xPFile As PivotField
Dim xStr As String
If Not Intersect(Target, Range("C2")) Is Nothing Then
Application.ScreenUpdating = False
Set xPTable = Worksheets("SHARE_CHANGE").PivotTables("PivotTable2")
Set xPFile = xPTable.PivotFields("category")
xStr = Target.Text
xPFile.ClearAllFilters
xPFile.CurrentPage = xStr
Application.ScreenUpdating = True
End If
End Sub
to confirm that the event is not firing I added a MsgBox in the beginning and nothing comes up
this is the only vba code in the workbook. macros are not disabled(I made the file). what else could be the reason?
Related
I created two dynamic tables on the same sheet.
Names are : "Tableau croisé dynamique1" and "Tableau croisé dynamique4"
I would like to use a cell reference to filter the two tables.
I found code for one table. I tried to duplicate it and change the variable.
The objective is to have the filters of the tables working the same.
If I filter for "week 26" both tables should show "week 26" data.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim xPTable As PivotTable
Dim xPFile As PivotField
Dim xStr As String
Dim xPTable4 As PivotTable
Dim xPFile4 As PivotField
Dim xStr4 As String
On Error Resume Next
If Intersect(Target, Range("B3")) Is Nothing Then Exit Sub
Application.ScreenUpdating = False
Set xPTable4 = Worksheets("Resumen_ventas").PivotTables("Tableau croisé dynamique4")
Set xPFile4 = xPTable.PivotFields("SEMANA")
Set xPTable = Worksheets("Resumen_ventas").PivotTables("Tableau croisé dynamique1")
Set xPFile = xPTable.PivotFields("SEMANA")
xStr4 = Target.Text
xStr = Target.Text
xPFile.ClearAllFilters
xPFile.CurrentPage = xStr
xPFile4.ClearAllFilters
xPFile4.CurrentPage = xStr4
Application.ScreenUpdating = True
End Sub
Excel screen shot here of the situation
the "SEMANA" field for each PivotTable must be visible on the sheet (drag it under "Filters" to make them PageFields
https://learn.microsoft.com/en-us/office/vba/api/excel.pivotfield.currentpage
You have to disable events for that, because some the ClearAllFilters() method triggers another Change event on the sheet.
Set xPFile4 = xPTable.PivotFields("SEMANA")
corrected in:
Set xPFile4 = xPTable4.PivotFields("SEMANA")
Code:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim xPTable As PivotTable
Dim xPFile As PivotField
Dim xStr As String
Dim xPTable4 As PivotTable
Dim xPFile4 As PivotField
Dim xStr4 As String
On Error Resume Next
If Intersect(Target, Range("B3")) Is Nothing Then Exit Sub
Set Target2 = Range("B4")
Application.ScreenUpdating = False
Set xPTable4 = Worksheets("Resumen_ventas").PivotTables("Tableau croisé dynamique4")
Set xPFile4 = xPTable4.PivotFields("SEMANA")
xStr4 = Target2.Text
Application.EnableEvents = False
xPFile4.ClearAllFilters
Application.EnableEvents = True
xPFile4.CurrentPage = xStr4
Set xPTable = Worksheets("Resumen_ventas").PivotTables("Tableau croisé dynamique1")
Set xPFile = xPTable.PivotFields("SEMANA")
xStr = Target2.Text
Application.EnableEvents = False
xPFile.ClearAllFilters
Application.EnableEvents = True
xPFile.CurrentPage = xStr
Application.ScreenUpdating = True
End Sub
I am fairly new to VBA and struglling with the idea on how to merge both of these subs into one, as i need to enable dynamic filters for two separate Pivots.
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, Range("L3:L4")) Is Nothing Then Exit Sub
Application.ScreenUpdating = False
Set xPTable = Worksheets("Summary").PivotTables("PivotTable1")
Set xPFile = xPTable.PivotFields("Machine")
xStr = Target.Text
xPFile.ClearAllFilters
xPFile.CurrentPage = xStr
Application.ScreenUpdating = True
End Sub
To combine with this
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, Range("P16:P17")) Is Nothing Then Exit Sub
Application.ScreenUpdating = False
Set xPTable = Worksheets("Summary").PivotTables("PivotTable2")
Set xPFile = xPTable.PivotFields("Machine")
xStr = Target.Text
xPFile.ClearAllFilters
xPFile.CurrentPage = xStr
Application.ScreenUpdating = True
End Sub
Appreciate any help, thank you!
Rather than just Exiting if there is no intersection, flip it around and proceed if there is an intersection.
Your code, refactored along with a few other improvements
Private Sub Worksheet_Change(ByVal Target As Range)
Dim xPTable As PivotTable
Dim xPFile As PivotField
Dim xStr As String
Application.ScreenUpdating = False
If Target.CountLarge > 1 Then
' User changed >1 cells. What now?
Exit Sub
End If
' On Error Resume Next <~~ don't do this globally!
If Not Intersect(Target, Me.Range("L3:L4")) Is Nothing Then
On Error Resume Next '<~~ Keep it tight around a potential error
' If the Change event is on Sheet Summary, use Me instead
Set xPTable = Me.PivotTables("PivotTable1")
' If the Change Event is NOT on Sheet Summary, be explicit on the workbook
'Set xPTable = Me.Parent.Worksheets("Summary").PivotTables("PivotTable1")
On Error GoTo 0
ElseIf Not Intersect(Target, Me.Range("P16:P17")) Is Nothing Then
On Error Resume Next
Set xPTable = Me.PivotTables("PivotTable2")
On Error GoTo 0
End If
If Not xPTable Is Nothing Then
On Error Resume Next '<~~ in case Machine doesn't exist
Set xPFile = xPTable.PivotFields("Machine")
On Error GoTo 0
If Not xPFile Is Nothing Then
xStr = Target.Value ' .Text is dangerous. Eg it can truncate if the column is too narrow
xPFile.ClearAllFilters
xPFile.CurrentPage = xStr
End If
End If
Application.ScreenUpdating = True
End Sub
I think there are more options for refactoring.
Put the basic routine into a seperate sub in a modul. This sub can then be called from the _change-events of both sheets. Advantage: if you want to change the logic of the sub - you do it in one place, not two. Or maybe there will be a third sheet that wants to use the same logic. (DRY-principle: don't repeat yourself)
I like to "externalize" on error resume next if necessary into tryGet-functions. Thereby minimizing the risk of its usage (which is in this case ok)
This is the generic sub - based on chris neilsens suggestion plus the comments from VBasic2008
Maybe you adjust the name of the sub to be more precise in what you want to achieve.
Public Sub handleMachineField(Target As Range, RangeToCheck As Range, PTName As String)
On Error GoTo err_handleMachineField
Dim xPTable As PivotTable
Dim xPFile As PivotField
Dim xStr As String
Application.ScreenUpdating = False
If Target.CountLarge > 1 Then
' User changed >1 cells. What now?
Exit Sub
End If
If Not Intersect(Target, RangeToCheck) Is Nothing Then
Set xPTable = tryGetPivotTable(Target.Parent, PTName)
End If
If Not xPTable Is Nothing Then
Set xPFile = tryGetPivotField(xPTable, "Machine")
If Not xPFile Is Nothing Then
xStr = Target.Value ' .Text is dangerous. Eg it can truncate if the column is too narrow
Application.EnableEvents = False
xPFile.ClearAllFilters
xPFile.CurrentPage = xStr
Application.EnableEvents = True
End If
End If
exit_handleMachineField:
Application.ScreenUpdating = True
Application.EnableEvents = True
Exit Sub
err_handleMachineField:
MsgBox Err.Description
Resume exit_handleMachineField
End Sub
Public Function tryGetPivotTable(ws As Worksheet, PTName As String) As PivotTable
'in case pivot table does not exist no error is thrown
'calling sub has to check for nothing instead
On Error Resume Next
Set tryGetPivotTable = ws.PivotTables(PTName)
On Error GoTo 0
End Function
Public Function tryGetPivotField(pt As PivotTable, FieldName As String) As PivotField
'in case field does not exist no error is thrown
'calling sub has to check for nothing instead
On Error Resume Next
Set tryGetPivotField = pt.PivotFields(FieldName)
On Error GoTo 0
End Function
And this is how you would call it form the worksheet events:
Private Sub Worksheet_Change(ByVal Target As Range)
handleMachineField Target, Me.Range("L3:L4"), "PivotTable1"
End Sub
By the way: this is another advantage of putting the check into a sub. When reading the code in the change-event you immediately know what will happen - you don't have to read through all the code lines to understand what is going on.
I'm trying to create a function that filters a pivot table based on a cell value. the target cell is on C2 in Sheet1. the pivot table is in the same sheet. any idea why this sub doesn't work?
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, Range("C2:C3")) Is Nothing Then Exit Sub
Application.ScreenUpdating = False
Set xPTable = Worksheets("Sheet1").PivotTables("PivotTable2")
Set xPFile = xPTable.PivotFields("category")
xStr = Target.Text
xPFile.ClearAllFilters
xPFile.CurrentPage = xStr
Application.ScreenUpdating = True
End Sub
I am trying to run multiple worksheet change events for filtering a number of pivot tables on a seperate sheet to where the pivot tables are, but I don't know how to combine the two macros. Both macros work on a standalone basis. Can anyone show me how to combine them? Macro 1:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim xPTable As PivotTable
Dim xPFile As PivotField
Dim xStr As String
Dim Pvt As String
On Error Resume Next
If Intersect(Target, Range("C9:C10")) Is Nothing Then Exit Sub
Application.ScreenUpdating = False
For Each xPTable In Worksheets("Pivot").PivotTables
Pvt = xPTable.Name
If Pvt = "PivotTable2" Or Pvt = "PivotTable4" Or Pvt = "PivotTable5" Or Pvt = "PivotTable6" Then
Set xPTable = Worksheets("Pivot").PivotTables(Pvt)
Set xPFile = xPTable.PivotFields("Code")
xStr = Target.Text
xPFile.ClearAllFilters
xPFile.CurrentPage = xStr
Else
End If
Next xPTable
Application.ScreenUpdating = True
End Sub
Macro 2:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim xPTable As PivotTable
Dim xPFile As PivotField
Dim xStr As String
Dim Pvt As String
On Error Resume Next
If Intersect(Target, Range("C11:C12")) Is Nothing Then Exit Sub
Application.ScreenUpdating = False
For Each xPTable In Worksheets("Pivot").PivotTables
Pvt = xPTable.Name
If Pvt = "PivotTable1" Or Pvt = "PivotTable3" Then
Set xPTable = Worksheets("Pivot").PivotTables(Pvt)
Set xPFile = xPTable.PivotFields("Ref")
xStr = Target.Text
xPFile.ClearAllFilters
xPFile.CurrentPage = xStr
Else
End If
Next xPTable
Application.ScreenUpdating = True
End Sub
Any help would be much appreciated.
Modify your Worksheet_Change events to simply call other macros.
Note that this change event can only be called from the sheet that you have the macro stored which means you may need to know the sheet the cell was changed on if you plan to call macros to operate on a different sheet. You can find the sheet that had the change using Target.Parent.Name
Private Sub Worksheet_Change(ByVal Target As Range)
Macro1 Target
Macro2 Target
End Sub
Sub Macro1(Target As Range)
If Intersect(Target, Range("C9:C10")) Is Nothing Then Exit Sub
'Rest of your code here for this change event
End Sub
Sub Macro2(Target As Range)
If Intersect(Target, Range("C11:C12")) Is Nothing Then Exit Sub
'Rest of your code here for this change event
End Sub
I am trying to color the background of all cells in column B whose content has changed via VBA.
The background changes if I manually update the cells but not when it changes via VBA. I can not get why it is not changing with the VBA.
In the worksheet module for the sheet called OriginalData I have
Private Sub Worksheet_Change(ByVal Target As Range)
Dim c As Range
Dim nName As String, nEmail As String
Application.EnableEvents = False
For Each c In Target
If c.Column = 2 And Target <> "" Then
c.Interior.Color = RGB(255, 255, 0)
End If
Next c
Application.EnableEvents = True
End Sub
I am updating the Column 2 on OriginalData with
Sub FindReplace_Updated_UnMatched_NAMES_Original_Prepperd_2()
Dim FindValues As Variant
Dim ReplaceValues As Variant
Dim wsFR As Excel.Worksheet
Dim wsTarget As Excel.Worksheet
Dim lRow As Long
Dim i As Long
Sheets("Updated_UnMatched").Select
Set wsFR = ThisWorkbook.Worksheets("Updated_UnMatched")
Set wsTarget = ThisWorkbook.Worksheets("OriginalData")
lRow = wsFR.Range("C" & wsFR.Rows.Count).End(xlUp).Row
FindValues = wsFR.Range("C1:C" & lRow).Value
ReplaceValues = wsFR.Range("D1:D" & lRow).Value
With wsTarget
If IsArray(FindValues) Then
For i = 2 To UBound(FindValues)
.Columns("B:B").Replace FindValues(i, 1), ReplaceValues(i, 1), xlWhole, xlByColumns, False
Next i
Else
End If
End With
End Sub
You likely errored out on Target <> "" and got stuck with Application.EnableEvents = False environment state.
First, go to the VBE's Immediate Windows (Ctrl+G) and enter the command Application.EnableEvents = True. While in the VBE, make this modification to your code for multiple Target cell counts.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim c As Range
Dim nName As String, nEmail As String
Application.EnableEvents = False
For Each c In Target
If c.Column = 2 And c.Value <> "" Then '<~~ c <> "", not Target <> ""
c.Interior.Color = RGB(255, 255, 0)
End If
Next c
Application.EnableEvents = True
End Sub
That should be enough to get you going.
When there is some errors during event handler execution, it doesn't work properly for next times. You can find and fix the errors and it will work properly.
As a quick fix, you can do these steps:
Add On Error Resume Next at the beginning of Worksheet_Change to
prevent errors make your code stop working.
Save your workbook in a macro enabled format and reopen it enabling
active content.
Run macro and it will work properly.
I tested your code and it worked for me in Excel 2013.
It is strongly recommended to fix your errors instead of hiding them using On Error Resume Next.