AW: mehrere Spalten auf einmal in Pivot ziehen
15.05.2010 11:50:21
fcs
Hallo Maria,
manuell kommst du um die um die Sysiphus-Arbeit nicht herum.
Es gibt keine Option, mit der man die Berechnungsfunktion vorgeben kann. Sobald in der Spalte eines Pivotfeldes eine leere Zelle oder Text vorhanden ist verwendet Excel automatisch die Anzahl-Funktion.
Nachfolgend 2 Makros, mit denen du dir das Anlegen vieler Summen-Felder im Datenbereich erleichtern kannst.
Gruß
Franz
'Erstellt unter Excel 2007 - Kompatibilitäts-Modus
Sub Pivot_Daten_Summenfelder_A()
Dim pvTab As PivotTable, pvField As PivotField, I As Long
Dim rngSpaltentitel As Range, Zelle As Range, A
Dim sMsgTitel As String, iFehler%
'Funktioniert nur, wenn Datenquelle der Pivottabelle eine Excel-Tabelle ist
'Makro starten wenn Tabelle mit der angelegten PivotTabelle aktiv.
'Pivottabelle sollte noch keine Felder im Datenbereich enthalten
sMsgTitel = "Pivottabelle - Datenbereichfelder anlegen"
On Error GoTo Fehler
iFehler = 1
Set pvTab = ActiveSheet.PivotTables(1)
iFehler = 2
Set rngSpaltentitel = Application.InputBox( _
Prompt:="Bitte in Datenquelle den Bereich mit den Spaltentiteln markieren, " _
& "die als Summenfelder im Datenbereich eingefügt werden sollen.", _
Title:=sMsgTitel, Type:=8)
'1. Spalte der Datenquelle ermitteln
iFehler = 3
With pvTab
A = .SourceData
A = Mid(A, InStr(1, A, "!") + 2)
If InStr(1, A, "C") > 0 Then
'R1C1-Schreibweise
A = Mid(A, InStr(1, A, "C") + 1)
ElseIf InStr(1, A, "S") > 0 Then
'Z1S1-Schreibweise
A = Mid(A, InStr(1, A, "S") + 1)
Else
MsgBox "Bitte Schreibweise von SourceData prüfen und Code anpassen" _
& vbLf & "SourceData: " & .SourceData
GoTo Fehler
End If
A = Val(Left(A, InStr(1, A, ":") - 1))
A = A - 1
End With
'Datenbereichsfelder anlegen
iFehler = 4
With rngSpaltentitel
For I = .Column - A To .Column + .Columns.Count - 1 - A
With pvTab
.AddDataField Field:=.PivotFields(I), _
Caption:="Summe " & .PivotFields(I).Name, Function:=xlSum
End With
Next
End With
Err.Clear
Fehler:
With Err
Select Case .Number
Case 0 'Alles OK
Case 13 'Type-Fehler - Bereichsauswahl wurde abgebrochen
If iFehler 2 Then
MsgBox "Fehler-Nr.: " & .Number & vbLf & .Description, _
vbInformation + vbOKOnly, sMsgTitel
End If
Case 1004
Select Case iFehler
Case 1
MsgBox "Fehler-Nr.: " & .Number & vbLf & _
"Aktive Tabelle enthält keine Pivot-Tabelle", _
vbInformation + vbOKOnly, sMsgTitel
Case 4
MsgBox "Fehler-Nr.: " & .Number & vbLf _
& "Feldname ""Summe " & pvTab.PivotFields(I).Name & """ existiert schon.", _
vbInformation + vbOKOnly, sMsgTitel
Resume Next
Case Else
MsgBox "Fehler-Nr.: " & .Number & vbLf & .Description, _
vbInformation + vbOKOnly, sMsgTitel
End Select
Case Else
MsgBox "Fehler-Nr.: " & .Number & vbLf & .Description, _
vbInformation + vbOKOnly, sMsgTitel
End Select
End With
End Sub
'Erstellt unter Excel 2007 - Kompatibilitäts-Modus
Sub Pivot_Daten_Summenfelder_B()
Dim pvTab As PivotTable, I%, Nr_Startfeld%, Nr_LetztesFeld%
Dim sMsgTitel As String, sMsgText As String, iFehler%
sMsgTitel = "Pivottabelle - Datenbereichfelder anlegen"
'Makro starten wenn Tabelle mit der angelegten PivotTabelle aktiv.
'Pivottabelle sollte noch keine Pivotfelder im Datenbereich enthalten
On Error GoTo Fehler
iFehler = 1
Set pvTab = ActiveSheet.PivotTables(1)
sMsgText = "Pivot-Feldes angeben, das als Summenfeld im " _
& "Datenbereich eingefügt werden soll."
Nr_Startfeld = Application.InputBox( _
Prompt:="Bitte lfnd. Nr des 1. " & sMsgText, _
Title:=sMsgTitel, Default:=5, Type:=1)
If Nr_Startfeld = 0 Then GoTo Fehler
Nr_LetztesFeld = Application.InputBox( _
Prompt:="Bitte lfnd. Nr des letzten" & sMsgText _
& vbLf & "999 = bis zum letzten Pivot-Feld", _
Title:=sMsgTitel, Default:=999, Type:=1)
If Nr_LetztesFeld = 0 Then GoTo Fehler
With pvTab
If Nr_LetztesFeld > .PivotFields.Count Or Nr_LetztesFeld = 999 Then
Nr_LetztesFeld = .PivotFields.Count
End If
iFehler = 4
'Datenbereichsfelder anlegen
For I = Nr_Startfeld To Nr_LetztesFeld
.AddDataField Field:=.PivotFields(I), _
Caption:="Summe " & .PivotFields(I).Name, Function:=xlSum
Next
End With
Err.Clear
Fehler:
With Err
Select Case .Number
Case 0 'Alles OK
Case 1004
Select Case iFehler
Case 1
MsgBox "Fehler-Nr.: " & .Number & vbLf & _
"Aktive Tabelle enthält keine Pivot-Tabelle", _
vbInformation + vbOKOnly, sMsgTitel
Case 4
MsgBox "Fehler-Nr.: " & .Number & vbLf _
& "Feldname ""Summe " & pvTab.PivotFields(I).Name & """ existiert schon.", _
vbInformation + vbOKOnly, sMsgTitel
Resume Next
Case Else
MsgBox "Fehler-Nr.: " & .Number & vbLf & .Description, _
vbInformation + vbOKOnly, sMsgTitel
End Select
Case Else
MsgBox "Fehler-Nr.: " & .Number & vbLf & .Description, _
vbInformation + vbOKOnly, sMsgTitel
End Select
End With
Set pvTab = Nothing
End Sub