f2e4
05-20-2008, 04:40 AM
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
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
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
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