AW: Pivot Tabelle sortieren - alle Felder per VBA
08.05.2008 18:24:22
fcs
Hallo Andreas,
Pivot-Tabellen sind nun einmal ziemlich komplexe Objekte und unter VBA manchmal schwierig zu handhaben.
Ich hab nochmals umgebaut und eine Schleife eingebaut, die nur die Zeilenfelder in der Sortierschleife abarbeitet. Die Fehlermeldungen hab ich auch noch ein wenig modifiziert. Ich denke, dass es jetzt funktionieren sollte.
Gruß
Franz
Sub SortierePivot()
Dim SortierRef As Range
Dim SortierRefField As String
Dim pvField As PivotField, pvTable As PivotTable
Dim bolSortiert As Boolean, intFehler As Integer, strMsg As String
On Error GoTo Fehler
Auswaehlen:
intFehler = 1
Set SortierRef = Application.InputBox("Bitte Sortierreferenz markieren:" & vbLf & _
"Abbrechen verläßt die Sortierung.", "Sortierreferenz", Type:=8)
Application.ScreenUpdating = False
Application.EnableEvents = False
If SortierRef Is Nothing Then
Exit Sub
Else
intFehler = 2
SortierRefField = SortierRef.PivotField
MsgBox SortierRefField
intFehler = 3
Set pvTable = ActiveSheet.PivotTables(1)
For Each pvField In pvTable.RowFields
intFehler = 4
pvField.AutoSort xlDescending, SortierRefField
Next
bolSortiert = True
intFehler = 0
End If
Application.ScreenUpdating = True
Application.EnableEvents = True
If bolSortiert = True Then
MsgBox ("PivotTabelle ist sortiert")
End If
Exit Sub
Fehler:
strMsg = "Fehler " & Err.Number & " ist aufgetreten!" & vbLf & Err.Description
Select Case intFehler
Case 1 'Keine Zelle selektiert
MsgBox strMsg & vbLf & vbLf & "Fehler bei Selektion, keine Zelle selektiert!"
Case 2 'Zelle außerhalb der Pivot-Tabelle selektiert
If MsgBox(strMsg & vbLf & vbLf & SortierRef.Value _
& ": Zelle außerhalb der PivotTabelle wurde selektiert" _
& vbLf & vbLf & "Sortierreferenz neu markieren?", vbYesNo) = vbYes Then
Application.ScreenUpdating = True
Resume Auswaehlen
End If
Case 3
MsgBox strMsg & vbLf & vbLf & "Pivottabelle fehlt"
Case 4 'Unzulässiges Feld in Pivot-Tabelle selectiert
If MsgBox(strMsg & vbLf & vbLf & "Feldzuweisung bei Sortierung fehlerhaft" _
& vbLf & vbLf & "Sortierreferenz neu markieren?", vbYesNo) = vbYes Then
Application.ScreenUpdating = True
Resume Auswaehlen
End If
Case Else
MsgBox strMsg
End Select
End Sub