Error Trapping Workbook_SheetChange VBA Code

[hawk771960]

I could use some help with some error trapping for the following VBA code. This code very nicely controls 2 pivot tables filter values from a single cell value on a worksheet. The problem occurs when the value does not occur in the filter. I could use an elegant way to simply tell the user that the value does not exist for one or both of the Pivot Tables.

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
If Intersect(Target, Worksheets("Lookup").Range("A2")) Is Nothing Then Exit Sub

Dim pt1 As PivotTable
Dim pt2 As PivotTable
Dim Field1 As PivotField
Dim Field2 As PivotField
Dim NewCat1 As String
Dim NewCat2 As String

Set pt1 = Worksheets("Lookup").PivotTables("PTProd")
Set Field1 = pt1.PivotFields("Material Number End")
NewCat1 = Worksheets("Lookup").Range("A2").Value

Set pt2 = Worksheets("Lookup").PivotTables("PTClaim")
Set Field2 = pt2.PivotFields("Material")
NewCat2 = Worksheets("Lookup").Range("A2").Value

With pt
Field1.ClearAllFilters
Field1.CurrentPage = NewCat1
pt1.RefreshTable
Field2.ClearAllFilters
Field2.CurrentPage = NewCat2
pt2.RefreshTable
End With




End Sub

 

[RickXL]

Hi,

I always use "Option Explicit" and that told me that variable pt was not being used. Also, the associated "With/End With" construct was not doing anything. So I removed them.
And it seemed to be a bit redundant to use both NewCat1 and NewCat2 because they were both set to the same value. So I called them just NewCat.

When I single-stepped through the code, I noticed that the code ran more than once. This was probably not a major issue because of your Exit Sub line at the top but it can produce unending loops on occasion. So I added an Application.DisableEvents = True at the start. The problem with doing that is that if there is an error in the code then the events never get re-enabled and it never runs again. The way round that is to trap any errors and to go to a place where the code will exit and the events will have been reinstated. The basic construct is always:

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
    ' Dim statements here ...
    
    Application.EnableEvents = False
    On Error GoTo Err
    
    ' Main processing goes here ...


Err:
   Application.EnableEvents = True
End Sub

Finally, I created a worksheet variable called ws so that I did not need to keep repeating the worksheet name everywhere.



Moving on to the actual problem, one way to see what values are permitted is to ask the PivotTable what the values are. To do that you need to know that you can start from the PivotField and ask Excel to list out the associated PivotItems. You then need to compare the list of PivotItem Names with your filter value. The way I did it was like this:

        ok = False
        For Each pItem In Field.PivotItems
            If pItem.Name = NewCat Then
                ok = True
                Exit For
            End If
        Next

It is then possible to check the value of "ok" to see whether the filter value is valid or not. I displayed a Msgbox if the value was not valid.

The code was getting a bit long at this point and it was basically two copies of the same thing so I put the code in a loop and put the Table and Field names into an Array so that it would be possible to loop round them.

To add another Table you can just add another string to the pTable and pField arrays.

The only other thing I spotted was that the tables did not refresh automatically and so if the filters failed then they were never refreshed again. I added another refresh step at the top of the loop. Another way to do that would be to change the code at the top that exits the sub if A2 did not change. You could just do a refresh if A2 did not change, for instance.

The whole thing ended up looking like this:

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
    
    Dim pt          As PivotTable
    Dim Field       As PivotField
    Dim NewCat      As String
    Dim pItem       As PivotItem
    Dim ws          As Worksheet
    Dim ok          As Boolean
    Dim pTables     As Variant
    Dim pFields     As Variant
    Dim i           As Long
    
    Application.EnableEvents = False
    On Error GoTo Err
    
    Set ws = Worksheets("Lookup")
    If Intersect(Target, ws.Range("A2")) Is Nothing Then Exit Sub
    
    pTables = Array("PTProd", "PTClaim")
    pFields = Array("Material Number End", "Material")
    NewCat = ws.Range("A2").Value
    
    For i = LBound(pTables) To UBound(pTables)
        Set pt = ws.PivotTables(pTables(i))
        Set Field = pt.PivotFields(pFields(i))
        pt.RefreshTable
        
        ok = False
        For Each pItem In Field.PivotItems
            If pItem.Name = NewCat Then
                ok = True
                Exit For
            End If
        Next
        
        If ok Then
            Field.ClearAllFilters
            Field.CurrentPage = NewCat
            pt.RefreshTable
        Else
            MsgBox "Value " & NewCat & " not found in " & pTables(i) & "/" & pFields(i) _
                    & vbLf & "Filter not changed"
        End If
    Next
Err:
   Application.EnableEvents = True
End Sub

I hope it does not look too different.


Regards,

 

[RickXL]

OK, I kept testing the previous code and was not too happy with it.

The main issue was that when you changed a value in the underlying data the PivotTables did not automatically update.

Another issue was the fact that using PivotItems does not do exactly what I expected. It retained some previous values so if I re-used a filter value it would give unexpected results. This is the magic line of code that prevents that:

        ws.PivotTables(pTables(i)).PivotCache.MissingItemsLimit = xlMissingItemsNone

I also added some "With/End With" constructs. The Exit Sub line has now gone and the Application.EnableEvents = False line is crucial.

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
    Dim pTables     As Variant
    Dim pFields     As Variant
    Dim ws          As Worksheet
    Dim NewCat      As String
    Dim i           As Long
    Dim ok          As Boolean
    Dim pItem       As PivotItem
    
    Application.EnableEvents = False
    On Error GoTo Err
    
    pTables = Array("PTProd", "PTClaim")
    pFields = Array("Material Number End", "Material")
    
    Set ws = Worksheets("Lookup")
    NewCat = ws.Range("A2").Value


    For i = LBound(pTables) To UBound(pTables)
        With ws.PivotTables(pTables(i))
            .PivotCache.MissingItemsLimit = xlMissingItemsNone
            .PivotCache.refresh
            With .PivotFields(pFields(i))
                ok = False
                For Each pItem In .PivotItems
                    If pItem.Name = NewCat Then ok = True: Exit For
                Next
                If ok Then
                    .ClearAllFilters
                    .CurrentPage = NewCat
                Else
                    MsgBox "Value " & NewCat & " not found in " & pTables(i) & "/" & pFields(i) _
                            & vbLf & vbLf & "Filter not as requested"
                End If
            End With
        End With
    Next


Err:
   Application.EnableEvents = True
End Sub

Now you should be able to enter a number in A2 and the pivottables will change in unison.
If you change the underlying data then the pivottables should change and if an error is produced you should see a Msgbox.


Regards,