Speed up pivot table VBA code, avoid multiple recalculations

[Ronny]

Hello all,

I'm hoping for some help to speed up a macro for a pivot table.

I have a pivot table with a pivot field that contains about 100 pivot
items. I've written some VBA code that will decide if the pivot item
should be visible or not.

I could do this manually by place the pivot filed in the rows, uncheck
the "show all" box and re-check for the fields I want visible
(right now only about 5 of the just over 100 pivot items). This would
cause Excel to recalculate once and show only the pivot items I want
visible.
With my VBA code Excel recalculate the pivot table for each pivot item
that is either hidden or shown. I've tried to enclose everything in a
"With pivotfield - end with". I've also tried to change the
calculation to manual with Application.Calculation =
xlCalculationManual before running this sequence (and changing it back
to automatic afterwards). From earlier I've also experienced that
pivot tables re-calculate even if the calculation method is set to
manual.

Is there another way to speed up the code so that the pivot table is
not re-calculated for all 100 pivot items?

Some of the code I'm using (not including the parts not related to
this selection, error handlers etc.):

Dim PT As PivotTable
Dim PTF As PivotField
Dim PTI As PivotItems
Dim myPivotItem As PivotItem

'The variables are set as the pivot table, field and items I'm
working with

Application.Calculation = xlCalculationManual
With PTF

For Each myPivotItem In PTI

Select Case myPivotItem
Case "Item xxxxxxxx1"
myPivotItem.Visible = True
Debug.Print "Visible " & myPivotItem
Case " Item xxxxxxxx2"
myPivotItem.Visible = True
Debug.Print "Visible " & myPivotItem

'etc. etc. going through the different cases

Case Else
myPivotItem.Visible = False

End Select

Next

End With
Application.Calculation = xlCalculationAutomatic


I'd be happy for any help on speeding up this.

Ronny

 

[Lonnie M.]

Hi Ronny, I have built a pivot table generator that I update the data
weekly, that contains a large number of possible calculated fields. I
have added a worksheet that has combo boxes and radio buttons that
allow me to select the page fields, row fields, and data fields that I
want (including calculated fields). The default values are set when the
workbook is opened or when I click a reset button.
The first section contains criteria that can be selected as a 'page
field', 'row field' or 'Not Used'. My 'data fields' section contains
radio buttons that allow the data and calculated fields to be used or
not.
When I click the button to build the pivot table it launches a macro
that loads the page, row, and data fields into arrays.
These arrays are used to build the pivot table. See the code below for
an example of how the page and row fields are setup:
********************************************************************
'SETUP PVT TABLE
Set myRNG = Dws.Range(Cells(1, 1), _
Cells(Cells(Rows.Count, 1).End(xlUp).Row, _
Cells(1, Columns.Count).End(xlToLeft).Column))

Debug.Print myRNG.Address(0, 0)

ActiveWorkbook.PivotCaches.Add(SourceType:=xlDatabase, SourceData:= _
myRNG).CreatePivotTable TableDestination:="", TableName:= _
"PivotTable1", DefaultVersion:=xlPivotTableVersion10
ActiveSheet.PivotTableWizard TableDestination:=ActiveSheet.Cells(3, 1)
ActiveSheet.Cells(3, 1).Select

'Test for page & row fields
On Error Resume Next
If UBound(arrPg) + UBound(arrRow) > 1 Then
If Err = 0 Then ActiveSheet.PivotTables("PivotTable1").AddFields
PageFields:=arrPg, RowFields:=arrRow
'count # of row fields
Rf = ActiveSheet.PivotTables(1).RowFields.Count
End If
'If there is not a page or row field it will cause an error above
If Err Then
Err.Clear
If UBound(arrPg) > 0 Then
If Err = 0 Then
Debug.Print arrPg(UBound(arrPg))
'Page field is present so it will be added
ActiveSheet.PivotTables("PivotTable1").AddFields PageFields:=arrPg
End If
Else

End If
Err.Clear
If UBound(arrRow) > 0 Then
If Err = 0 Then
Rf = UBound(arrRow)
'Row field is present so it will be added
ActiveSheet.PivotTables("PivotTable1").AddFields RowFields:=arrRow
End If
End If
If Err Then Rf = 1
End If
Err.Clear
On Error GoTo 0
*************************************************************


The data fields I loop through. I have a procedure for the calculated
fields that tests to see if the calculated field was selected, if it
was I add the field.

'Data Field
'**************************************************************
On Error Resume Next
For X = 1 To UBound(arrTData)
If Err Then GoTo noTGT
With
ActiveSheet.PivotTables("PivotTable1").PivotFields(arrTData(X))
.Orientation = xlDataField
If Left(arrTData(X), 1) = "c" Then
.Caption = Right(arrTData(X), Len(arrTData(X)) - 1)
Else
If Right(arrTData(X), 5) = "Delta" Then
.Caption = Left(arrTData(X), Len(arrTData(X)) - 5)
& " Delta"
Else
.Caption = "Per " & Right(arrTData(X),
Len(arrTData(X)) - 3)
End If
End If
.Position = X
.Function = xlSum
.NumberFormat = "#,##0_);[Red](#,##0);""-""_)"
End With
If X = 2 Then
With ActiveSheet.PivotTables("PivotTable1").DataPivotField
.Orientation = xlColumnField
.Position = 1
End With
End If
Next X
noTGT:
Err.Clear
'**************************************************************

'Calc Fields
'**************************************************************
Private Sub CalcDataFiels()
Dim X%, Pos%

'BGT Calc Fields
'BGT Cumulative Calc Fields
Pos = dFieldPosition("BAC") + 1
'Cum BGT CV
If Worksheets("Menu").optbcalBCVd Then
ActiveSheet.PivotTables("PivotTable1").CalculatedFields.Add
"BGT_CV", _
"=cBCWP-cACWP", True
With
ActiveSheet.PivotTables("PivotTable1").PivotFields("BGT_CV")
.Orientation = xlDataField
.Caption = "BGT CV"
.Position = Pos
.NumberFormat = "#,##0_);[Red](#,##0);""-""_)"
End With
Pos = Pos + 1
End If

'Cum BGT SV
If Worksheets("Menu").optbcalBSVd Then
ActiveSheet.PivotTables("PivotTable1").CalculatedFields.Add
"BGT_SV", _
"=cBCWP-cBCWS", True
With
ActiveSheet.PivotTables("PivotTable1").PivotFields("BGT_SV")
.Orientation = xlDataField
.Caption = "BGT SV"
.Position = Pos
.NumberFormat = "#,##0_);[Red](#,##0);""-""_)"
End With
Pos = Pos + 1
End If
'**************************************************************

I hope that gives you some ideas--Lonnie M.

 

[Ronny]

Thank you for your reply, Lonnie M. This made me remember that I have
read that it is much better to work with arrays than objects.
I don't see how I can use your code directly. My pivot table already
exists so I just want to make changes to it, not create it.

I still thought an array could be helpful, but I'm lost at how to
apply the full array to the pivotfield at once, and not loop through
the array.

If I have:
PTF As PivotField
PTI As PivotItems
ArrayItem(t) As String

With PTF
For a = 0 To t
PTI(ArrayItem(a)).Visible = False
Next a
End With

I'm still doing one and one pivot item, and get a refresh of the
pivot table for all of them.

What I want to do is:
With PTF
PTI(ArrayItem()).Visible = False
End With

But I can't get any code to work in such a way..

Anyone that can help me?

Ronny

 

[Guest]

Ronny, try your original method with

PT.ManualUpdate = True