Infinite Pivot Table loop

[BKNewton29]

I've created a macro that will refresh pivot tables on a worksheet once a report filter is changed on the first pivto tbale on the page. The macro is split into two. The first routine makes sure that the pivot refresh macro is only triggered if a certain cell is changed.

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim Rnge As Range
Set Rnge = Application.Intersect(Target, Range("D19"))
If Not Rnge Is Nothing Then
Call Products_selected
End If
End Sub

The second routine updates the over pvot tables. However if seems to be on an eternal loop when it does start running and I can't work out why. Any help appreciated. Code below

Sub Products_selected() 'routine to list selected products in PivotTable1 on active sheet
Dim pvtField As PivotField
Dim pvtitem As PivotItem
Dim shtname As String, count As Integer
Dim pt As PivotTable, i As Integer, Piv As Integer
Dim Pivo As Integer
Dim ii As Integer
shtname = ActiveSheet.Name ' get current sheet name

Set pvtTable = Sheets(shtname).Range("C19").PivotTable

'clear existing list (if any)
If Sheets("Workings").Cells(2, 12) > 1 Then
Sheets("Workings").Select
Range(Cells(2, 12).Value).Select
Selection.Clear
Sheets(shtname).Select
End If

rw = 2 ' output row

For Each pvtitem In Worksheets(shtname).PivotTables("PivotTable1").PivotFields("Product Target").HiddenItems
If pvtitem.Visible Then

rw = rw + 1
Sheets("Workings").Cells(rw, 13).Value = pvtitem.Name

End If
Next pvtitem
ii = 0

For Each pt In ActiveSheet.PivotTables
ii = ii + 1
Next pt
'Update pivot tables in the sheet
For Pivo = 2 To ii
ActiveSheet.PivotTables("PivotTable" & Pivo).PivotCache.Refresh
Next Pivo
' ActiveWorkbook.RefreshAll
End Sub

 

[pcc]

try this

Sub Products_selected() 'routine to list selected products in PivotTable1 on active sheet
                              Application.EnableEvents = False  ' new line
Dim pvtField As PivotField
Dim pvtitem As PivotItem
Dim shtname As String, count As Integer
Dim pt As PivotTable, i As Integer, Piv As Integer
Dim Pivo As Integer
Dim ii As Integer
shtname = ActiveSheet.Name ' get current sheet name

Set pvtTable = Sheets(shtname).Range("C19").PivotTable

'clear existing list (if any)
If Sheets("Workings").Cells(2, 12) > 1 Then
Sheets("Workings").Select
Range(Cells(2, 12).Value).Select
Selection.Clear
Sheets(shtname).Select
End If

rw = 2 ' output row

For Each pvtitem In Worksheets(shtname).PivotTables("PivotTable1").PivotFields("Product Target").HiddenItems
If pvtitem.Visible Then

rw = rw + 1
Sheets("Workings").Cells(rw, 13).Value = pvtitem.Name

End If
Next pvtitem
ii = 0

For Each pt In ActiveSheet.PivotTables
ii = ii + 1
Next pt
'Update pivot tables in the sheet
For Pivo = 2 To ii
ActiveSheet.PivotTables("PivotTable" & Pivo).PivotCache.Refresh
Next Pivo
' ActiveWorkbook.RefreshAll
                                                     Application.EnableEvents = True  ' new line

End Sub

 

[BKNewton29]

pcc

Works perfectly

Thanks very much