Pivotfeld:Feststellen,ob "ALLE gewählt"+Markierung

Sub Pivot_Zeig_ALLE() Dim pvItem As PivotItem, pvField As PivotField, pvTable As PivotTable Set pvTable = ActiveSheet.PivotTables(1) Set pvField = pvTable.PivotFields For Each pvField In pvTable.PivotFields If not pvField.ShowAllItems = True Then MsgBox "TEST" End If Next pvField End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Option Explicit Sub PivotFelder_Checkoballeangezeigt() 'Prüft die Pivottabelle auf ausgebledete Items und färbt ggf. Labels rot Dim objPT As PivotTable, objPF As PivotField, objWks As Worksheet Dim bolPageField, bolHidden As Boolean Dim objFeld As PivotField On Error GoTo Fehler Set objWks = ActiveSheet Set objPT = objWks.PivotTables(1) objPT.RefreshTable For Each objPF In objPT.PivotFields With objPF 'If objPT.PageFields.Count > 0 Then If objPT.PageFields.Count > 0 Then 'Prüfen ob Seitenfeld bolPageField = False For Each objFeld In objPT.PageFields bolHidden = False If objPF.Name = objFeld.Name Then If objPF.DataRange.Value "(Alle)" Then bolHidden = True GoTo Kennzeichnen Else bolPageField = True End If End If Next End If If bolPageField = True Then GoTo Kennzeichnen If .HiddenItems.Count > 0 Then bolHidden = True Else bolHidden = False End If Kennzeichnen: If bolHidden = True Then .LabelRange.Interior.ColorIndex = 3 'rot MsgBox "Feld " & .Name & ": Es ist was ausgeblendet!" Else .LabelRange.Interior.ColorIndex = 15 'Schaltflächengrau MsgBox "Feld " & .Name & ": Es ist nichts ausgeblendet!" End If End With Next GoTo Beenden Fehler: MsgBox "Fehler Nummer: " & Err.Number & " ist aufgetreten!" & vbLf & Err.Description _ & vbLf & vbLf & "?" Beenden: Set objPT = Nothing: Set objPF = Nothing: Set objWks = Nothing End Sub Sub PivotFelder_LabelFarbe_zuruecksetzen() 'setz die Dim objPT As PivotTable, objPF As PivotField, objWks As Worksheet On Error GoTo Fehler Set objWks = ActiveSheet Set objPT = objWks.PivotTables(1) For Each objPF In objPT.PivotFields With objPF .LabelRange.Interior.ColorIndex = 15 'Schaltflächengrau End With Next GoTo Beenden Fehler: Beenden: Set objPT = Nothing: Set objPF = Nothing: Set objWks = Nothing End Sub

Hallo Andreas,
hier eine verbesserte Version. Mein erster Ansatz hatte Probleme mit Feldern, die in der Auswertung nicht verwendet werden.
Gruß
Franz


Sub PivotFelder_Check()
Dim objPivotTable
'Alle Pivot-Tabellen im aktiven Blatt prüfen
For Each objPivotTable In ActiveSheet.PivotTables
Call PivotFelder_Check_Items(objPT:=objPivotTable, bolMsgAus:=True, bolMsgAlle:=False)
Next
End Sub
Sub PivotFelder_Check_Items(ByVal objPT As PivotTable, _
Optional bolMsgAus As Boolean = True, _
Optional bolMsgAlle = False)
'Prüft die Felder der Pivottabelle auf ausgebledete Items und färbt ggf. Labels rot
Dim objPF As PivotField
Dim intFehler, strMsg As String
'bolMsgAus: Wenn True dann wird Meldung bei ausgeblendeten Items angezeigt
'bolMsgAlle:Wenn False dann keine Meldung wenn alle Items angezeigt werden
On Error GoTo Fehler
'Spaltenfelder prüfen
If objPT.ColumnFields.Count > 0 Then
intFehler = 1
For Each objPF In objPT.ColumnFields
With objPF
Call fncKennzeichnen(objPF, .HiddenItems.Count > 0, _
bolMsgAus, bolMsgAlle, objPT.Name & vbLf & "Spaltenfeld  ")
End With
ResumeFehler1:
Next
End If
'Zeilenfelder prüfen
intFehler = 0
If objPT.RowFields.Count > 0 Then
intFehler = 2
For Each objPF In objPT.RowFields
With objPF
Call fncKennzeichnen(objPF, .HiddenItems.Count > 0, _
bolMsgAus, bolMsgAlle, objPT.Name & vbLf & "Zeilenfeld  ")
End With
ResumeFehler2:
Next
End If
'Seitenfelder prüfen
intFehler = 0
If objPT.PageFields.Count > 0 Then
intFehler = 3
For Each objPF In objPT.PageFields
With objPF
Call fncKennzeichnen(objPF, .DataRange.Value  "(Alle)", _
bolMsgAus, bolMsgAlle, objPT.Name & vbLf & "Seitenfeld  ")
End With
ResumeFehler3:
Next
End If
GoTo Beenden
Fehler:
strMsg = "Fehler Nummer: " & Err.Number & " ist aufgetreten!" & vbLf & Err.Description
Select Case intFehler
Case 1
strMsg = strMsg & vbLf & vbLf & "Problem Spaltenfeld: " & objPF.Name
MsgBox strMsg: Resume ResumeFehler1
Case 2
strMsg = strMsg & vbLf & vbLf & "Problem Zeilenfeld: " & objPF.Name
MsgBox strMsg: Resume ResumeFehler2
Case 3
strMsg = strMsg & vbLf & vbLf & "Problem Seitenfeld: " & objPF.Name
MsgBox strMsg: Resume ResumeFehler3
Case Else
MsgBox strMsg
End Select
Beenden:
Set objPF = Nothing
End Sub
Private Function fncKennzeichnen(objPivotField As PivotField, _
bolAusgeblendet As Boolean, _
ByVal bolMsgAus As Boolean, _
ByVal bolMsgAlle As Boolean, _
Optional strMsg As String = "Feld  ") As Boolean
'Kennzeichnung der Ausgeblendeten Pivot-Felder und ggf. Ausgabe einer Meldung
On Error GoTo Fehler
With objPivotField
If bolAusgeblendet = True Then
.LabelRange.Interior.ColorIndex = 3 'rot
If bolMsgAus Then MsgBox strMsg & .Name & ":  Es sind Elemente ausgeblendet!"
Else
.LabelRange.Interior.ColorIndex = 15 'Schaltflächengrau
If bolMsgAlle Then MsgBox strMsg & .Name & ":  Alle Elemente werden angezeigt!"
End If
End With
fncKennzeichnen = True
Exit Function
Fehler:
MsgBox "Fehler Nummer: " & Err.Number & " ist aufgetreten!" & vbLf & Err.Description _
& vbLf & vbLf & "Feld: " & objPivotField.Name
fncKennzeichnen = False
End Function
Sub PivotFelder_LabelFarbe_zuruecksetzen()
'setz die
Dim objPT As PivotTable, objPF As PivotField, objWks As Worksheet
On Error GoTo Fehler
Set objWks = ActiveSheet
For Each objPT In objWks.PivotTables
For Each objPF In objPT.PivotFields
With objPF
.LabelRange.Interior.ColorIndex = 15 'Schaltflächengrau
End With
ResumeFehler:
Next
Next
GoTo Beenden
Fehler:
Resume ResumeFehler 'Nicht verwendete PivotFelder werden übersprungen
Beenden:
Set objPT = Nothing: Set objPF = Nothing: Set objWks = Nothing
End Sub

Beliebteste Forumthreads (12 Monate)

Pivotfeld:Feststellen,ob "ALLE gewählt"+Markierung

4
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

300 Forumthreads zu ähnlichen Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Pivotfeld:Feststellen,ob "ALLE gewählt"+Markierung

4 Beiträge zum Forumthread Beiträge zu diesem Forumthread

300 Forumthreads zu ähnlichen Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

4
Beiträge zum Forumthread

Beiträge zu diesem Forumthread