CODEWITHSUNDEEP
vbaexcelerror-handlingpivot-table
R3uK
R3uK

Reputation: 14537

VBA - GetPivotData - Can't trap Run-time error 1004

I'm working on a procedure to select a part of a Pivot Table and send that extract.

Everything is ok, except that I keep having a run-time error 1004 that I can't catch (to avoid it and keep looping) and so my loops don't work smoothly...

Here is the part that have a problem :

    On Error GoTo 0
    On Error GoTo NextSale
    If IsError(pt.GetPivotData("Amount", Pf.Name, Pi.Name, "Sales_Opp", PiO.Name)) Then GoTo NextSale
    Set Rg = pt.GetPivotData("Amount", Pf.Name, Pi.Name, "Sales_Opp", PiO.Name)
    On Error GoTo 0

    Set RgT = Union(RgT, Rg)
NextSale:

Because pt.GetPivotData("Amount", Pf.Name, Pi.Name, "Sales_Opp", PiO.Name) will throw a run-time error 1004, when the combination doesn't exist in the data and I just want to avoid being blocked in the loops.

I searched and yet didn't manage to fix this... IsError() and On Error GoTo doesn't work. I even checked in the options (Tools->Options->General->Error Trapping) and I'm already on Break on Unhandled Errors...

Here is the full code :

Sub testPt()
Dim Pt As PivotTable, _
    Pf As PivotField, _
    Pi As PivotItem, _
    PiO As PivotItem, _
    Ws As Worksheet, _
    TpStr As String, _
    RgT As Range, _
    Rg As Range

Set Ws = ThisWorkbook.Sheets("PT_All")

For Each Pt In Ws.PivotTables
    For Each Pf In Pt.PivotFields
        If Pf.Name <> "Sales" Then
        Else
            For Each Pi In Pf.PivotItems
                Set RgT = Pi.LabelRange
                For Each PiO In Pt.PivotFields("Sales_Opp").PivotItems

                    On Error GoTo 0
                    On Error GoTo NextSale
                    If IsError(Pt.GetPivotData("Amount", Pf.Name, Pi.Name, "Sales_Opp", PiO.Name)) Then GoTo NextSale
                    Set Rg = Pt.GetPivotData("Amount", Pf.Name, Pi.Name, "Sales_Opp", PiO.Name)
                    On Error GoTo 0

                    Set RgT = Union(RgT, Rg)
NextSale:
                Next PiO
                RgT.Select
                MsgBox RgT.Address
            Next Pi
        End If
    Next Pf
Next Pt

End Sub

Upvotes: 1

Views: 2930

Answers (2)

Tragamor
Tragamor

Reputation: 3634

The problem is probably something to do with the range error handling (or lack thereof).

The following code is untested but you should be able to work out where errors lie with it and adapt it to your requirements...

Sub testPt()
    Dim Pt As PivotTable, _
        Pf As PivotField, _
        Pi As PivotItem, _
        PiO As PivotItem, _
        TpStr As String, _
        RgT As Range, _
        Rg As Range

    Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("PT_All")

    For Each Pt In ws.PivotTables
        For Each Pf In Pt.PivotFields
            If Pf.Name = "Sales" Then
                For Each Pi In Pf.PivotItems
                    Set RgT = Pi.LabelRange
                    For Each PiO In Pt.PivotFields("Sales_Opp").PivotItems
                        Set Rg = Nothing
                        On Error Resume Next
                        Set Rg = Pt.GetPivotData("Amount", Pf.Name, Pi.Name, "Sales_Opp", PiO.Name)
                        On Error GoTo 0
                        If Not RgT Is Nothing Then
                            If Not Rg Is Nothing Then Set RgT = Union(RgT, Rg)
                        Else: If Not Rg Is Nothing Then Set RgT = Rg
                        End If
                    Next PiO
                Next Pi
            End If
        Next Pf
    Next Pt

    If Not RgT Is Nothing Then
        RgT.Select
        MsgBox RgT.Address
    Else: MsgBox "RgT is empty"
    End If

End Sub

Upvotes: 1

SeanC
SeanC

Reputation: 15923

I have a feeling that it is failing on the 2nd time though the routine, not the first.
It has successfully trapped the first error, but as there has been no Resume xxxxxx statement, it's still trying to do the error handling when it hits the next one. Nested error handling is not allowed, so it errors out.

Get rid of the On Error Goto 0 lines, and change the remaining On Error to

On Error GoTo Err_Handlr

Then, just before the End Sub, add the following:

Unexpected_Err:
Exit Sub

Err_Handlr:
If err.number=1004
    Resume NextSale
Else
    Msgbox "Can't handle " & err.description
    Resume Unexpected_Err
end if

Note that I'm looking for the expected error number - this means that if some other part breaks, I can at least get informed about it, instead of racing out of control through whatever else may happen as a side effect

Upvotes: 2

Related Questions