AW: Pivottabellenbericht - Filter synchronisieren
16.10.2013 18:48:55
fcs
Hallo Danek,
die Filtereinstellungen in 2 oder mehreren Pivot-Tabellenberichten zu synchronisieren ist mühsehlig zu programmieren.
Extreme Probleme bereiten dabei Dezimalzalen und Datumswerte als Feldnamen und Pivot-Items.
Ich hab hier jetz mal einen Anlauf genaommen dies für Excel 2010 umzusetzen.
Grundvoraussetzung ist, dass die Feldnamen (Berichtsfelder/Zeilen und Spaltenfeldnamen) in den Pivotberichten identisch sind. Bei Wertefiltern müssen dann auch die entsprechenden Feldnamen im Datenbereich übereinstimmen.
Wenn das nicht der Fall ist, dann müssen im Code die Feldnamen der Master-Pivot angegeben werden, die nicht synchronisiert werden sollen.
mfg
Franz
'Code in einem allgemeinen Modul der Datei
Option Explicit
'Erstellt unter Excel 2010 -- fcs 2013-10-16 -- Version 01
'- Nicht lauffähig unter Excel 2003 !!!
'- unter Excel 2007 nicht getestet
Sub Pivotfilter_Sychronisieren()
'Synchronisiert die Filtereinstellungen mehrerer Pivottabellenberichte
Dim pvMaster As PivotTable, pvSlave() As PivotTable
Dim pvMasterField As PivotField, pvItem As PivotItem
Dim pvSlaveField As PivotField
Dim AnzPvSlave As Integer, intSlave As Integer
Dim strTemp As String
Application.EnableEvents = False
'Pivottabellen setzen
With ActiveWorkbook
'Master-Pivottabellenbericht setzen, dessen Einstellungen für die anderen
'Pivotberichte übernommen werden sollen.
Set pvMaster = .Worksheets("Feld04").PivotTables(1) 'Blattname anpassen!!!
'Slave-Tabellen definieren, die synchronisiert werden sollen
AnzPvSlave = 1 'Anzahl ggf. anpassen
ReDim pvSlave(1 To AnzPvSlave)
Set pvSlave(1) = .Worksheets("Feld06").PivotTables(1) 'Blattname anpassen!!!
'ggf. weitere Slave-Pivottabellen setzen
End With
For intSlave = 1 To AnzPvSlave
pvSlave(intSlave).ClearAllFilters
'Berichtsfelder
'- funktioniert nicht bei mehren ausgewählten Elementen in einem BerichtsFeld
For Each pvMasterField In pvMaster.PageFields
Select Case pvMasterField.Name
Case "Berichtsfeld1", "Berichtsfeld2"
'diese Feldnamen nicht synchronisieren
Case Else
Set pvSlaveField = pvSlave(intSlave).PivotFields(pvMasterField.Name)
pvSlaveField.EnableMultiplePageItems = pvMasterField.EnableMultiplePageItems
strTemp = pvMasterField.LabelRange.Offset(0, 1).Value
Select Case strTemp
Case "(All)", "(Alle)"
'keine Filter für Berichtsfeld gesetzt
'do nothing
Case "(Mehrere Elemente)", "(Multi-Selektion)" 'englischen text anpassen !!!
If fncPageFieldsMultiple(pvMasterField, pvSlaveField) = False Then
MsgBox "Probleme beim Synchronisieren des Berichtsfeldes: " & pvMasterField. _
Name
Err.Clear
GoTo Beenden
End If
Case Else
pvSlaveField.CurrentPage = strTemp
End Select
End Select
Next
'Zeilenfelder
For Each pvMasterField In pvMaster.RowFields
Select Case pvMasterField.Name
Case "Zeilenfeld1", "Zeilenfeld2"
'diese ZeilenFeldnamen nicht synchronisieren
Case Else
Set pvSlaveField = pvSlave(intSlave).PivotFields(pvMasterField.Name)
If fncSynchronizePivotField(pvMasterField, pvSlaveField, _
bolDateMsgBox:=True) = False Then GoTo Beenden
End Select
Next
'Spaltenfelder
For Each pvMasterField In pvMaster.ColumnFields
Select Case pvMasterField.Name
Case "Zeilenfeld1", "Zeilenfeld2"
'diese SpaltenFeldnamen nicht synchronisieren
Case Else
Set pvSlaveField = pvSlave(intSlave).PivotFields(pvMasterField.Name)
If fncSynchronizePivotField(pvMasterField, pvSlaveField, _
bolDateMsgBox:=True) = False Then GoTo Beenden
End Select
Next
Next
Beenden:
Erase pvSlave
Set pvMaster = Nothing
Application.EnableEvents = True
End Sub
Function fncSynchronizePivotField(objMasterField As PivotField, _
objSlaveField As PivotField, _
Optional bolDateMsgBox As Boolean = False) As Boolean
'Synchronisierung von Zeilen-/Spaltenfeldern in 2 Pivottabellen
'bolDateMsgBox: Wenn True, dann wird eine Meldung angezeigt, wenn ein _
Datumswert in der Dropdownauswahl gewählt wurde
fncSynchronizePivotField = True
On Error GoTo Fehler
Dim pvItem As PivotItem, pvItemNr As Integer
Dim pvFilter As PivotFilter
Dim strTemp As String
If objMasterField.PivotFilters.Count = 0 Then
'es ist kein Beschriftungs oder Wertefilter gewählt sondern evtl. nur _
einzelne Werte in den Einzelwerten gewählt/abgewählt.
For pvItemNr = 1 To objMasterField.PivotItems.Count
Set pvItem = objMasterField.PivotItems(pvItemNr)
If IsDate(pvItem.Name) Or IsDate(Right(pvItem.Name, 10)) Then
Select Case objMasterField.Name
Case "Minuten", "Minutes", "Stunden", "Hours", "Tage", "Days"
'Keine Meldung bei gruppierten Zeitangaben
Case "Monate" To "Months", "Quartale", "Quarters", "Jahre" To "Years"
'Keine Meldung bei gruppierten Datums/Zeitangaben
Case Else
If bolDateMsgBox = True Then
MsgBox "Pivot Items mit manueller Auswahl von Datumswerten " _
& "können noch nicht verarbeitet werden. " & vbLf _
& "Bitte bei der Auswahl den Datumsfilter verwenden", _
vbInformation + vbOKOnly, _
"Synchronisation Pivot - Manueller Datumsfilter: " _
& objMasterField.Name
End If
End Select
Exit For 'Pivotfeld wird nicht weiter bearbeitet
Else
If pvItem.Visible = False Then
strTemp = pvItem.Name
objSlaveField.PivotItems(strTemp).Visible = False
End If
End If
Next
Else
'es ist ein Beschriftungs oder Wertefilter gesetzt
For Each pvFilter In objMasterField.PivotFilters
With pvFilter
Select Case .FilterType
'Beschriftungs - Werte-Filter
Case xlCaptionEquals, xlCaptionDoesNotEqual, _
xlCaptionBeginsWith, xlCaptionDoesNotBeginWith, _
xlCaptionEndsWith, xlCaptionDoesNotEndWith, _
xlCaptionContains, xlCaptionDoesNotContain, _
xlCaptionIsGreaterThan, xlCaptionIsGreaterThanOrEqualTo, _
xlCaptionIsLessThan, xlCaptionIsLessThanOrEqualTo
objSlaveField.PivotFilters.Add Type:=.FilterType, Value1:=.Value1
Case xlCaptionIsBetween, xlCaptionIsNotBetween
objSlaveField.PivotFilters.Add Type:=.FilterType, Value1:=.Value1, _
Value2:=.Value2
'Beschriftung - Datums-Filter
Case xlSpecificDate, xlAfter, xlBefore 'Datum/Zeit gleich, nach, vor
objSlaveField.PivotFilters.Add Type:=.FilterType, Value1:=CDbl(.Value1)
Case xlDateBetween, xlDateNotBetween 'Datum/Zeit von-bis, nicht von-bis
objSlaveField.PivotFilters.Add Type:=.FilterType, Value1:=CDbl(.Value1), _
Value2:=CDbl(.Value2)
Case xlDateLastWeek, xlDateThisWeek, xlDateNextWeek 'Woche letzte, _
dieser, nächster
objSlaveField.PivotFilters.Add Type:=.FilterType
Case xlDateLastMonth, xlDateThisMonth, xlDateNextMonth 'Monat letzter, _
diese, nächste
objSlaveField.PivotFilters.Add Type:=.FilterType
Case xlDateLastQuarter, xlDateThisQuarter, xlDateNextQuarter 'Quartal letzte, _
dieser, nächster
objSlaveField.PivotFilters.Add Type:=.FilterType
Case xlYearToDate, xlDateLastYear, xlDateThisYear, xlDateNextYear
'Jahr bis heute, letztes, dieses, nächstes
Case xlAllDatesInPeriodQuarter1, xlAllDatesInPeriodQuarter2, _
xlAllDatesInPeriodQuarter3, xlAllDatesInPeriodQuarter4
'Quartal im aktuellen Jahr
objSlaveField.PivotFilters.Add Type:=.FilterType
Case xlAllDatesInPeriodJanuary, xlAllDatesInPeriodFebruary, _
xlAllDatesInPeriodMarch, xlAllDatesInPeriodApril, xlAllDatesInPeriodMay, _
xlAllDatesInPeriodJune, xlAllDatesInPeriodJuly, xlAllDatesInPeriodAugust, _
xlAllDatesInPeriodSeptember, xlAllDatesInPeriodOctober, _
xlAllDatesInPeriodNovember, xlAllDatesInPeriodDecember
'Monat im aktuellen Jahr
objSlaveField.PivotFilters.Add Type:=.FilterType
'Filter für Ergebnisse der berechneten Daten
Case xlValueIsGreaterThan, xlValueIsGreaterThanOrEqualTo, _
xlValueIsLessThan, xlValueIsLessThanOrEqualTo, _
xlValueEquals, xlValueDoesNotEqual
objSlaveField.PivotFilters.Add Type:=.FilterType, DataField:=.DataField, _
Value1:=.Value1
Case xlValueIsBetween, xlValueIsNotBetween
objSlaveField.PivotFilters.Add Type:=.FilterType, DataField:=.DataField, _
Value1:=.Value1, Value2:=.Value2
Case xlTopCount, xlBottomCount, _
xlTopPercent, xlTopSum
objSlaveField.PivotFilters.Add Type:=.FilterType, DataField:=.DataField, _
Value1:=.Value1
Case xlBottomPercent, xlBottomSum
objSlaveField.PivotFilters.Add Type:=.FilterType, DataField:=.DataField, _
Value1:=.Value1, Order:=.Order
Case Else
MsgBox "Der gewählte Filter wird vom Makro noch nicht unterstützt", _
vbInformation + vbOKOnly, _
"Synchronisation Pivot - Manueller Datumsfilter: " _
& objMasterField.Name
End Select
End With
Next
End If
Fehler:
With Err
Select Case .Number
Case 0 'Alles OK
Case Else
strTemp = "Probleme mit Feld """ & objMasterField.Name
MsgBox "Fehler-Nr.: " & .Number & vbLf & .Description & vbLf & vbLf _
& strTemp
fncSynchronizePivotField = False
End Select
End With
Set pvItem = Nothing: Set pvFilter = Nothing
End Function
Function fncPageFieldsMultiple(objMasterField As PivotField, _
objSlaveField As PivotField) As Boolean
'Selektion in 2 Berichtsfeldern synchronisieren
Dim pvItem As PivotItem, pvItemSlave As PivotItem, bolFound As Boolean
Dim strTemp As String
fncPageFieldsMultiple = True
On Error GoTo Fehler
For Each pvItemSlave In objSlaveField.PivotItems
bolFound = False
strTemp = pvItemSlave.Name
For Each pvItem In objMasterField.PivotItems
If pvItem.Name = strTemp Then
bolFound = True
pvItemSlave.Visible = pvItem.Visible
Exit For
End If
Next
If bolFound = False Then
pvItemSlave.Visible = False
End If
Next
Fehler:
With Err
Select Case .Number
Case 0 'Alles OK
Case Else
strTemp = "Probleme mit Berichts-Feld """ & objMasterField.Name
MsgBox "Fehler-Nr.: " & .Number & vbLf & .Description & vbLf & vbLf _
& strTemp
fncPageFieldsMultiple = False
End Select
End With
End Function