VBA Code for copying and pasting data from pivot to another excel

[Monicasinha]

Hi

Can you please suggest a better vba code for copying and pasting data from a pivot to another excel.

The code below is taking around 20 seconds. Can something be done so that it takes lesser time.
----------------------------------------------------------------------------------------------------------------------------------

Set PTable = Openbook.Worksheets("PivotTable").PivotTables("Pivot1")

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

Selection.Copy

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


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

Selection.Copy

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


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

Selection.Copy

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


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

Selection.Copy

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



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

Selection.Copy

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



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

Selection.Copy

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

 

[ceranes]

Hello,

Yes, there are a few ways to optimize the code to make it run faster and more efficiently. One method is to disable certain Excel features, such as screen updating and automatic calculation, while the code is running.

Another approach is to minimize the number of times you interact with the worksheet by consolidating some of the operations.

Here's an optimized version of the code:

Sub CopyPivotTableData()

    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

    Dim PTable As PivotTable
    Set PTable = ThisWorkbook.Worksheets("PivotTable").PivotTables("Pivot1")

    Dim wsDestination As Worksheet
    Set wsDestination = ThisWorkbook.Worksheets("FAB Solution")

    Dim arrFieldNames() As Variant
    arrFieldNames = Array("Activity", "Country/Location", "Career Level", "Service Group")

    Dim arrDestRanges() As Variant
    arrDestRanges = Array("E5", "L5", "M5", "N5")

    Dim i As Long
    For i = LBound(arrFieldNames) To UBound(arrFieldNames)
        PTable.PivotSelect "'" & arrFieldNames(i) & "'[All]", xlLabelOnly, True
        Selection.Copy
        wsDestination.Range(arrDestRanges(i)).PasteSpecial xlPasteValues
    Next i

    PTable.PivotSelect "'Billable Hours' Resource", xlDataOnly, True
    Selection.Copy
    wsDestination.Range("G5").PasteSpecial xlPasteValues

    PTable.PivotSelect "'Revenue Recognition' Resource", xlDataOnly, True
    Selection.Copy
    wsDestination.Range("H5").PasteSpecial xlPasteValues

    Application.CutCopyMode = False
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic

End Sub

Hope this helps you. Good luck!

Chris

 

[Monicasinha]

Thank you