AW: Pivottabellen - Einträge löschen
14.10.2010 07:53:16
Luschi
Hallo Heinz
das folgende Makro bereinigt Unstimmigkeiten zwischen Quelldaten und Pivottabelle:
Sub DeleteOldPivotItemsWB()
'Löschen von nicht mehr verwendeten Einträgen in Pivot-Tabellen
'basierend auf MS-KB (Q202232)
'Wenn man sehr viel an der Pivot-Tabelle herumdoktert, also oft in der
'Struktur verändert, Daten reinkopiert oder löscht, dann kommt es zu
'Unstimmigkeiten zwischen den Ausgangsdaten und dem PivotCache der Pivottabelle.
'erstaunlich, daß auch Excel 2007 & 2010 immer noch von diesem Leiden betroffen sind
'Deshalb ab und zu dieses Makro starten
Dim ws As Worksheet, _
pt As PivotTable, pf As PivotField, pi As PivotItem
On Error Resume Next
For Each ws In ActiveWorkbook.Worksheets
For Each pt In ws.PivotTables
pt.RefreshTable
For Each pf In pt.PivotFields
For Each pi In pf.PivotItems
If pi.RecordCount = 0 And Not pi.IsCalculated Then
pi.Delete
End If
Next
Next
Next
Next
End Sub
Also Daten der Pivottabelle aktualisieren und dann das obere Makro starten.
Die folgende 2 Makros könnten dabei auch interessant sein:
Sub PivotCachesAnzeigen()
'Zählt alle Pivot-Tabelle und zeigt deren
'Datenquelle an
Dim p, anz, piv
For Each p In Worksheets
anz = anz + p.PivotTables.Count
Next
For Each p In ActiveWorkbook.PivotCaches
piv = piv & p.SourceData & vbLf
Next
MsgBox "Mappe enthält " & anz & " Pivot-Tabellen und " & _
vbLf & ActiveWorkbook.PivotCaches.Count & _
" Pivot-Datenquellen :" & vbLf & vbLf & piv
Set p = Nothing
End Sub
Sub PivotCachesAngleichen()
'von NoNet
'Wenn es mehrere Pivottabellen mit gleichen Ausgangsdaten gibt,
'dann kann es vorkommen, daß die Exceldatei sich aufbläht, da der PivotCache
'immer größer wird.
'Mit diesem Makro wird der PivotCach wieder angeglichen
Dim ws, ws2, p1, p2
For Each ws In Worksheets
For Each p1 In ws.PivotTables
For Each ws2 In Worksheets
For Each p2 In ws2.PivotTables
If ws.Name ws2.Name Or p1.Name p2.Name Then
If p1.SourceData = p2.SourceData Then
p2.CacheIndex = p1.CacheIndex
End If
End If
Next
Next
Next
Next
Set ws = Nothing
Set ws2 = Nothing
Set p1 = Nothing
Set p2 = Nothing
End Sub
Gruß von Luschi
aus klein-Paris