'Обновление списков сводной таблицы

Sub tt()

Dim oPt As PivotTable

Dim oSh As Worksheet

w_Events.EventsChange False

On Error Resume Next

For Each oSh In ActiveWorkbook.Sheets 'цикл по всем листам книги

' If oSh.Name = "Pt_Date" Then

If oSh.PivotTables.Count > 0 Then

Debug.Print oSh.Name & " ======================================="

For Each oPt In oSh.PivotTables 'цикл по всем сводным таблицам

Call ClearUnusedPivotItems(oPt)

Next 'oPt

End If

' End If

Next 'oSh

w_Events.EventsChange True

End Sub

Private Sub ClearUnusedPivotItems(oPivotTable As Object)

Dim oPivotField As Object

Dim oPivotItem As Object

Dim nIdx As Long

Dim bCalc As Boolean

For Each oPivotField In oPivotTable.RowFields

If oPivotField.value <> "Data" Then

nIdx = 1

Do While (nIdx <= oPivotField.PivotItems.Count)

Set oPivotItem = oPivotField.PivotItems(nIdx)

On Error GoTo Err_

If oPivotItem.IsCalculated Then

strBar = "Calculated"

nIdx = nIdx + 1

Else

strBar = "Delete"

oPivotItem.Delete

End If

On Error GoTo 0

Loop

End If

Next

For Each oPivotField In oPivotTable.ColumnFields

If oPivotField.value <> "Data" Then

nIdx = 1

Do While (nIdx <= oPivotField.PivotItems.Count)

Set oPivotItem = oPivotField.PivotItems(nIdx)

On Error GoTo Err_

If oPivotItem.IsCalculated Then

nIdx = nIdx + 1

Else

oPivotItem.Delete

End If

On Error GoTo 0

Loop

End If

Next

For Each oPivotField In oPivotTable.PageFields

nIdx = 1

Do While (nIdx <= oPivotField.PivotItems.Count)

Set oPivotItem = oPivotField.PivotItems(nIdx)

On Error GoTo Err_

If oPivotItem.IsCalculated Then

nIdx = nIdx + 1

Else

oPivotItem.Delete

End If

On Error GoTo 0

Loop

Next

Exit Sub

Err_:

'Debug.Print oPivotItem.Caption & " - " & strBar

Application.StatusBar = oPivotItem.Caption & " - " & strBar: strBar = ""

nIdx = nIdx + 1

Resume Next

End Sub