Ideas to speeds up PivotTable VBA

[f2e4]

Hi guys,

I was hoping someone out there could look at the code below and see if there are any changes they could make to speed it up or make it more efficient.

At the minute, the code either slows my computer right down or totally stalls excel.

Thanks for your help

[VBA]
Sub Create_Weekly_Report()

Application.ScreenUpdating = False
Application.Calculation = xlCalculationAutomatic

'Store values from comboboxes
weekending = ActiveSheet.ComboBox9.Value
locationdrop = ActiveSheet.ComboBox10.Value

If ActiveSheet.ComboBox9.Value = Null Or ActiveSheet.ComboBox9.Value = "" Or ActiveSheet.ComboBox10.Value = Null Or ActiveSheet.ComboBox10.Value = "" Then
response = MsgBox(prompt:="Please ensure that all fields are populated", Buttons:=vbOK, Title:="Error") = vbOK
Exit Sub
End If

'Store values for renaming pivottable
Dim pivotweek As String
pivotweek = weekending & " " & locationdrop
Dim wksNew As Worksheet
Set wksNew = Sheets.Add(After:=Sheets(Sheets.Count))

'Create PivotTable in new worksheet
ActiveWorkbook.PivotCaches.Add(SourceType:=xlDatabase, _
SourceData:="pivots").CreatePivotTable TableDestination:=wksNew.Range("A1"), _
TableName:=pivotweek

'Store value to rename new worksheet
Dim wksname As String
wksname = weekending & " - " & locationdrop

'Rename new worksheet
ActNm = ActiveSheet.Name
On Error Resume Next
ActiveSheet.Name = wksSummary
NoName: If Err.Number = 1004 Then ActiveSheet.Name = Replace("BBB", "BBB", wksname)
If ActiveSheet.Name = ActNm Then GoTo NoName
On Error GoTo 0

'Add data fields and format Pivottable
With ActiveSheet.PivotTables(pivotweek).PivotFields("Status")
.Orientation = xlRowField
.Position = 1
End With
With ActiveSheet.PivotTables(pivotweek).PivotFields("Project")
.Orientation = xlRowField
.Position = 2
End With
With ActiveSheet.PivotTables(pivotweek).PivotFields("Project Name")
.Orientation = xlRowField
.Position = 3
End With
With ActiveSheet.PivotTables(pivotweek).PivotFields("Sector")
.Orientation = xlRowField
.Position = 4
End With
With ActiveSheet.PivotTables(pivotweek).PivotFields("Project Manager")
.Orientation = xlRowField
.Position = 5
End With
With ActiveSheet.PivotTables(pivotweek).PivotFields("Staff Member")
.Orientation = xlColumnField
.Position = 1
End With
ActiveSheet.PivotTables(pivotweek).PivotFields("Sector").Subtotals = Array( _
False, False, False, False, False, False, False, False, False, False, False, False)
ActiveSheet.PivotTables(pivotweek).PivotFields("Project Manager"). _
Subtotals = Array(False, False, False, False, False, False, False, False, False, False, _
False, False)
ActiveSheet.PivotTables(pivotweek).PivotFields("Project").Subtotals = Array _
(False, False, False, False, False, False, False, False, False, False, False, False)
ActiveSheet.PivotTables(pivotweek).PivotFields("Project Name").Subtotals = _
Array(False, False, False, False, False, False, False, False, False, False, False, False)
ActiveSheet.PivotTables(pivotweek).AddDataField ActiveSheet.PivotTables( _
pivotweek).PivotFields(weekending), "Sum of week", xlSum
Application.ScreenUpdating = True ' The weekending value is from one of the comboboxes.
End Sub

[/VBA]

[Bob Phillips]

Set calculation to manual at the start and just recalkculate the sheet at the end.

[Paul_Hossler]

1. I added a bunch of With's and used a PT variable, since I figured it wouldn't hurt. I've been told that if Excel has fewer objects to de-reference or shorter object chains it goes faster, but not sure this will be significant. Not tested

[vba]
Sub Create_Weekly_Report()
Dim pt As PivotTable '<<<<<<<<<<<<<<

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual '<<<<<<<<<<<<<<<<<<<<

'Store values from comboboxes
With ActiveSheet
weekending = .ComboBox9.Value
locationdrop = .ComboBox10.Value

If .ComboBox9.Value = Null Or .ComboBox9.Value = "" Or .ComboBox10.Value = Null Or .ComboBox10.Value = "" Then
response = MsgBox(prompt:="Please ensure that all fields are populated", Buttons:=vbOK, Title:="Error") = vbOK
Exit Sub
End If
End With

'Store values for renaming pivottable
Dim pivotweek As String
pivotweek = weekending & " " & locationdrop

Dim wksNew As Worksheet
Set wksNew = Sheets.Add(After:=Sheets(Sheets.Count))

'Create PivotTable in new worksheet
ActiveWorkbook.PivotCaches.Add(SourceType:=xlDatabase, _
SourceData:="pivots").CreatePivotTable TableDestination:=wksNew.Range("A1"), _
TableName:=pivotweek

Set pt = ActiveWorkbook.PivotTables(pivotweek) '<<<<<<<<<<<<<<<<<<<

'Store value to rename new worksheet
Dim wksname As String
wksname = weekending & " - " & locationdrop

'Rename new worksheet
ActNm = ActiveSheet.Name
On Error Resume Next
ActiveSheet.Name = wksSummary

NoName: If Err.Number = 1004 Then ActiveSheet.Name = Replace("BBB", "BBB", wksname)
If ActiveSheet.Name = ActNm Then GoTo NoName
On Error GoTo 0

With pt

'Add data fields and format Pivottable
With .PivotFields("Status")
.Orientation = xlRowField
.Position = 1
End With
With .PivotFields("Project")
.Orientation = xlRowField
.Position = 2
End With
With .PivotFields("Project Name")
.Orientation = xlRowField
.Position = 3
End With
With .PivotFields("Sector")
.Orientation = xlRowField
.Position = 4
End With
With .PivotFields("Project Manager")
.Orientation = xlRowField
.Position = 5
End With
With .PivotFields("Staff Member")
.Orientation = xlColumnField
.Position = 1
End With


.PivotFields("Sector").Subtotals = Array( _
False, False, False, False, False, False, False, False, False, False, False, False)

.PivotFields("Project Manager"). _
Subtotals = Array(False, False, False, False, False, False, False, False, False, False, _
False, False)

.PivotFields("Project").Subtotals = Array _
(False, False, False, False, False, False, False, False, False, False, False, False)

.PivotFields("Project Name").Subtotals = _
Array(False, False, False, False, False, False, False, False, False, False, False, False)

' The weekending value is from one of the comboboxes.
.AddDataField ActiveSheet.PivotTables(pivotweek).PivotFields(weekending), "Sum of week", xlSum

End If

Application.ScreenUpdating = True
End Sub
[/vba]


2. but I was wondering if you were to comment this out

[vba]
' The weekending value is from one of the comboboxes.
.AddDataField ActiveSheet.PivotTables(pivotweek).PivotFields(weekending), "Sum of week", xlSum
[/vba]

and re-run if it would go faster? You seems to be adding a PT field from another PT and I'm wondering if there's a lot of overhead to do that??????

IF so, you might need another way to get the data

Paul