Faster vba code for adding a total column, creating pivot and then copying pasting data

[Monicasinha]

Hi

I have written vba code for below set of activities

1. In Source file, add a column in the end with heading as "Total". This column should have sum formula for last 60 rows ( heading mnth1 to mnth60). I didnt know how to refer to the column names, so I have just referred to column numbers ( I am expecting that mnth1 to mnth 60 will always lie in the same columns in this source file)
2. A pivot table needs to be made considering entire range of the source file.
3. The pivot table need to have some filters.
4. Data needs to be copied from this pivot table to a worksheet in destination workbook.

This vba codes takes more than 5 minutes to run, the excel becomes not responding.
Can you please help what to change in this code:
------------------------------------------------------------------------------
Sub Macro5()



Dim PSheet As Worksheet

Dim DSheet As Worksheet

Dim PCache As PivotCache

Dim PTable As PivotTable

Dim PField As PivotField

Dim exists As Boolean

Dim PRange As Range

Dim LastRow As Long

Dim LastCol As Long

Dim LastCol1 As Long

Dim rng As Range, MyResultsRng As Range

Dim TotalCoverage As Double

Dim totalLabel As String

Dim cell As Range



FileToOpen = Application.GetOpenFilename(filefilter:="Excelfiles(*.xlsb),*xlsx*")

Set Openbook = Application.Workbooks.Open(FileToOpen)


Application.ScreenUpdating = False

Application.Calculation = xlCalculationManual


'Defining sheets and Columns

Set DSheet = Worksheets("Apples")

LastRow = DSheet.Cells(Rows.Count, 1).End(xlUp).Row

LastCol = DSheet.Cells(1, Columns.Count).End(xlToLeft).Column

LastCol1 = LastCol + 1

Const FirstCol As Long = 30 ' "AD"


‘Adding last column “Total” in the worksheet “Apples”

Set MyResultsRng = DSheet.Range(DSheet.Cells(2, LastCol1), DSheet.Cells(LastRow, LastCol1))

Dim i As Long

For i = 2 To LastRow



For Each cell In MyResultsRng(1)

Set rng = DSheet.Range(DSheet.Cells(i, FirstCol), DSheet.Cells(i, LastCol))

TotalCoverage = Application.WorksheetFunction.Sum(rng.Value)

MyResultsRng.Cells(i - 1, 1).Formula = "=Sum(" & rng.Address(False, False) & ")"

Next cell

Next i

Set cell = DSheet.Cells(1, LastCol1)

cell.Value = "Total"



‘Creating Pivot table of the entire data range in workseet “Apples”



For Each Worksheet In Openbook.Worksheets

If Worksheet.Name = "PivotTable" Then

Openbook.Worksheets("PivotTable").Delete

End If

Next



Sheets.Add Before:=ActiveSheet

ActiveSheet.Name = "PivotTable"



Set PSheet = Worksheets("PivotTable")





'Define Data Range



Set PRange = DSheet.Range(DSheet.Cells(1, 1), DSheet.Cells(LastRow, LastCol1)).CurrentRegion



Set PCache = ActiveWorkbook.PivotCaches.Create _

(SourceType:=xlDatabase, SourceData:=PRange)



Set PTable = PCache.CreatePivotTable(TableDestination:=PSheet.Cells(1, 1), TableName:="Pivot1")

With PTable

.PivotFields("Category").Orientation = xlPageField

.PivotFields("Category").Position = 1

.PivotFields("Category").ClearAllFilters

.PivotFields("Category").CurrentPage = "Resource"

End With

With PTable

.PivotFields("Activity").Orientation = xlRowField

.PivotFields("Activity").Position = 1

.PivotFields("Description").Orientation = xlRowField

.PivotFields("Description").Position = 2

.PivotFields("Service Group").Orientation = xlRowField

.PivotFields("Service Group").Position = 3

.PivotFields("Country/Location").Orientation = xlRowField

.PivotFields("Country/Location").Position = 4

.PivotFields("Cost Center Career Track").Orientation = xlRowField

.PivotFields("Cost Center Career Track").Position = 5

.PivotFields("Economic Profile").Orientation = xlRowField

.PivotFields("Economic Profile").Position = 6

.PivotFields("Career Level").Orientation = xlRowField

.PivotFields("Career Level").Position = 7

End With

PTable.AddDataField PSheet.PivotTables( _

"Pivot1").PivotFields("Total"), "Sum of Total", xlSum

With PTable.PivotFields("Type")

.Orientation = xlColumnField

.Position = 1

End With

PTable.RowAxisLayout xlTabularRow





With PTable

For Each PField In .PivotFields

PField.Subtotals(1) = True

PField.Subtotals(1) = False

Next PField

End With



ColorArray = Array("Red", "Green", "Yellow")

With PTable.PivotFields("Color")

For i = 1 To .PivotItems.Count

If IsError(Application.Match(.PivotItems(i).Name, ColorArray, 0)) Then

.PivotItems(i).Visible = False

Else

.PivotItems(i).Visible = True

End If

Next i

End With



TypeArray = Array("Billable Hours", "Revenue Recognition")

With PTable.PivotFields("Type")

For i = 1 To .PivotItems.Count

If IsError(Application.Match(.PivotItems(i).Name, TypeArray, 0)) Then

.PivotItems(i).Visible = False

Else

.PivotItems(i).Visible = True

End If

Next i

End With



PTable.RepeatAllLabels xlRepeatLabels

PTable.ColumnGrand = False

PTable.RowGrand = False



‘Copying data from pivot table to destination file



PTable.PivotSelect "'Activity'[All]", xlLabelOnly, True

'Application.CutCopyMode = False

Selection.Copy

ThisWorkbook.Worksheets("DXC Solution").Range("E5").PasteSpecial xlPasteValues



PTable.PivotSelect "'Country/Location'[All]", xlLabelOnly, True

Application.CutCopyMode = False

Selection.Copy

ThisWorkbook.Worksheets("DXC Solution").Range("L5").PasteSpecial xlPasteValues



PTable.PivotSelect "'Career Level'[All]", xlLabelOnly, True

Application.CutCopyMode = False

Selection.Copy

ThisWorkbook.Worksheets("DXC Solution").Range("M5").PasteSpecial xlPasteValues



PTable.PivotSelect "'Service Group'[All]", xlLabelOnly, True

Application.CutCopyMode = False

Selection.Copy

ThisWorkbook.Worksheets("DXC Solution").Range("N5").PasteSpecial xlPasteValues



PTable.PivotSelect "'Description'[All]", xlLabelOnly, True

Application.CutCopyMode = False

Selection.Copy

ThisWorkbook.Worksheets("DXC Solution").Range("T5").PasteSpecial xlPasteValues



PTable.PivotSelect "'Economic Profile'[All]", xlLabelOnly, True

Application.CutCopyMode = False

Selection.Copy

ThisWorkbook.Worksheets("DXC Solution").Range("U5").PasteSpecial xlPasteValues



PTable.PivotSelect "'Billable Hours' Resource", xlDataOnly, True

Application.CutCopyMode = False

Selection.Copy

ThisWorkbook.Worksheets("DXC Solution").Range("G5").PasteSpecial xlPasteValues



PTable.PivotSelect "'Revenue Recognition' Resource", xlDataOnly, True

Application.CutCopyMode = False

Selection.Copy

ThisWorkbook.Worksheets("DXC Solution").Range("H5").PasteSpecial xlPasteValues



Application.Calculation = xlCalculationAutomatic

ActiveWorkbook.Save

Application.ScreenUpdating = True

End Sub