Pivot table: iterating through each item takes forever

[Bering]

Hello,
my pivot table is in sheet PivotTableSheet, in the same sheet, in range P4:W4, I have a set of formulae performed on the select item in column A.
The macro below iterates through each item in column A and copies the range ("A4,P4:W4") to Sheet3 cell B3 at each change.
It works like a charm but it takes so long that I'd be better off doing it manually... I have a total of 166 items at the moment.
Any help would be much appreciated! Thank you.

Option Explicit
Sub CopyPivotResultsByGL()

    Dim wsPivot As Worksheet
    Dim wsDest As Worksheet
    Dim pvtTable As PivotTable
    Dim pvtField As PivotField
    Dim pvtItem As PivotItem
    Dim destRow As Long
    Dim cell As Range


    ' Define your pivot table worksheet and destination worksheet
    Set wsPivot = ThisWorkbook.Sheets("PivotTableSheet") ' Change the name as needed
    Set wsDest = ThisWorkbook.Sheets("Sheet3")
    
    ' Clear the destination sheet
    wsDest.Rows("3:" & wsDest.Rows.Count).Clear
    
    ' Find the pivot table
    Set pvtTable = wsPivot.PivotTables(1) ' Adjust if you have more than one pivot table
    
    ' Set the starting row for the destination
    destRow = 3

    ' Loop through each item in the General Ledger field
    Set pvtField = pvtTable.PivotFields("General Ledger")
    For Each pvtItem In pvtField.PivotItems
    
        ' Show only the current General Ledger item
        pvtField.ClearAllFilters
        pvtItem.Visible = True
        Dim otherItem As Object
        For Each otherItem In pvtField.PivotItems
            If otherItem.Name <> pvtItem.Name Then
                otherItem.Visible = False
            End If
        Next otherItem

        ' Copy the visible data to the destination sheet
        wsPivot.Range("A4,P4:W4").Copy
        wsDest.Cells(destRow, 2).PasteSpecial xlPasteValues
        destRow = destRow + 1


        ' Show all items again for the next iteration
        pvtItem.Visible = True
    Next pvtItem

    ' Reset the pivot table to show all items
    pvtField.ClearAllFilters

    MsgBox "Copying complete!"
    
End Sub

 

[Domenic]

Does this help?

1) Before you start looping through each item in your pivotfield, set ManualUpdate to True...

pvtTable.ManualUpdate = True

2) After you've finished looping through each item in your pivotfield, and you've cleared your pivotfield, set ManualUpdate back to False...

pvtTable.ManualUpdate = False

 

[RoryA]

I'd also set Application.Screenupdating = False at the start.