Anzeige
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Ergebnisse aus Pivot-Tabellen einkopieren

Ergebnisse aus Pivot-Tabellen einkopieren
11.12.2017 17:34:45
Kisska
Hallo zusammen,
ich habe eine etwas knifflige Angelegenheit:
Aus zwei Pivot-Tabellen sollen Daten in eine formatierte Tabelle untereinander einkopiert werden.
Meine Datei (300 MB groß) besteht aus 3 Tabellenblättern:
1) Auswertung
2) Datenquelle_1
3) Datenquelle_2
Pivot-Tabelle zu "Datenquelle_1" steht bei der "Auswertung" in den Spalten K bis M und die zweite Pivot-Tabelle zu "Datenquelle_2" steht in den Spalten P bis Q.
In der ersten Spalte der beiden Pivot-Tabelle wird das "Jahr" ausgegeben, in der zweiten die "Firma" - bei der ersten Pivot-Tabelle ist es die Firma_A und bei der zweiten Pivot-Tabelle ist es die Firma_B. In der dritten Spalte werden die Umsätze ausgegeben. Zusätzlich haben beiden Pivot-Tabellen zwei Berichtsfilter.
Nun möchte ich die Ergebnisse der Pivot-Tabellen in eine formatierte Tabelle einkopieren, die in den Spalten A bis C steht.
Dafür habe ich diesen Code geschrieben:

Sub Alle_Makros()
Daten_loeschen
Pivots_aktualisieren
Pivot1_einkopieren
Pivot2_einkopieren
End Sub
Sub Daten_loeschen()
On Error Resume Next
If MsgBox("Alle Daten löschen?", vbYesNo, "Alle Daten löschen") = vbYes Then
Range("Tabelle_Auswertung").Delete
End If
End Sub
Sub Pivots_aktualisieren()
Application.ScreenUpdating = False
' Alle Pivot-Tabellen im Tabellenblatt aktualisieren
Dim TB As Worksheet
Dim PT As PivotTable
Set TB = Worksheets("Auswertung")
For Each PT In TB.PivotTables
PT.RefreshTable
Next PT
Application.ScreenUpdating = True
End Sub
Sub Pivot1_einkopieren()
If Range("K6") = "(Leer)" Then
Exit Sub
Else
On Error GoTo 0
Range("K6").Activate
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Copy
Range("A3").Activate
ActiveSheet.Paste
Application.CutCopyMode = False
Application.ScreenUpdating = True
End If
End Sub
Sub Pivot2_einkopieren()
If Range("P6") = "(Leer)" Then
Exit Sub
Else
Application.ScreenUpdating = False
On Error Resume Next
Range("P6").Activate
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Copy
Range("A3").Activate
Selection.End(xlDown).Activate
ActiveCell.Offset(rowoffset:=1, columnoffset:=0).Activate
ActiveSheet.Paste
Application.CutCopyMode = False
Application.Goto Reference:=Range("A1")
Application.ScreenUpdating = True
End If
End Sub
Nun meine Fragen:
1) Wenn Datenquelle_1 leer ist und ich das Makro laufen lasse, dann werden Ergebnisse der Pivot2 nicht in die Tabelle einkopiert. Wie kann das gelöst werden?
2) Wenn ich mehr Berichtsfilter aufnehmen möchte, dann verschieben sich die Bezüge. Kann man die Bezüge im Code variabel schreiben?
Viele Grüße
Kisska

2
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Ergebnisse aus Pivot-Tabellen einkopieren
12.12.2017 12:07:18
fcs
Hallo Kisska,
Grundsätzlich gibt es mehrere Range-Eigenschaften eines Pivotberichtes deren Eigenschaften Row und Rows.Count man auswerten kann, um die zu kopierenden Tabellenzeilen mit den relevanten Daten des Pivotberichtes zu bestimmen, z.B:
- RowRange
- TableRange1
- DataBodyRange
Falls es mit dem angepassten Makro nicht funktioniert dann müsstest du mal eine Datei mit anonymiserten Beispiel-Daten hier hochladen.
Gruß
Franz
Sub Alle_Makros()
Daten_loeschen
Pivots_aktualisieren
Pivot1_einkopieren
Pivot2_einkopieren
End Sub
Sub Daten_loeschen()
On Error Resume Next
If MsgBox("Alle Daten löschen?", vbYesNo, "Alle Daten löschen") = vbYes Then
Range("Tabelle_Auswertung").ClearContents 'statt delete
End If
End Sub
Sub Pivots_aktualisieren()
Application.ScreenUpdating = False
' Alle Pivot-Tabellen im Tabellenblatt aktualisieren
Dim TB As Worksheet
Dim PT As PivotTable
Set TB = Worksheets("Auswertung")
For Each PT In TB.PivotTables
PT.RefreshTable
Next PT
Application.ScreenUpdating = True
End Sub
Sub Pivot1_einkopieren()
Dim pvTab As PivotTable
Dim wks As Worksheet
Dim Zeile_1 As Long, Zeile_L As Long, Spalte_1 As Long
Set wks = ActiveWorkbook.Worksheets("Auswertung")
Application.ScreenUpdating = False
With wks
Set pvTab = .PivotTables(1)
With pvTab
If .RowRange.Rows.Count = 1 Then
'keine Daten unterhalb der Spalten Titel
GoTo Beenden
Else
Spalte_1 = .TableRange1.Column
Zeile_1 = .DataBodyRange.Row
Zeile_L = Zeile_1 + .DataBodyRange.Rows.Count - 1
End If
End With
If .Cells(Zeile_1, Spalte_1).Text = "(Leer)" Then
GoTo Beenden
Else
.Range(.Cells(Zeile_1, Spalte_1), .Cells(Zeile_L, Spalte_1 + 2)).Copy
.Range("A3").PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
End If
End With
Beenden:
Application.ScreenUpdating = True
End Sub
Sub Pivot2_einkopieren()
Dim pvTab As PivotTable
Dim wks As Worksheet
Dim Zeile_1 As Long, Zeile_L As Long, Spalte_1 As Long
Set wks = ActiveWorkbook.Worksheets("Auswertung")
Application.ScreenUpdating = False
With wks
Set pvTab = .PivotTables(2)
With pvTab
If .RowRange.Rows.Count = 1 Then
'keine Daten unterhalb der Spalten Titel
GoTo Beenden
Else
Spalte_1 = .TableRange1.Column
Zeile_1 = .DataBodyRange.Row
Zeile_L = Zeile_1 + .DataBodyRange.Rows.Count - 1
End If
End With
If .Cells(Zeile_1, Spalte_1).Text = "(Leer)" Then
GoTo Beenden
Else
.Range(.Cells(Zeile_1, Spalte_1), .Cells(Zeile_L, Spalte_1 + 2)).Copy
If .Range("A3").Text = "" Then 'keine Daten in 1.Pivot vorhanden
.Range("A3").PasteSpecial Paste:=xlPasteValues
ElseIf .Range("A4").Text = "" Then '1. Pivot hatte nur 1 Datenzeile
.Range("A3").PasteSpecial Paste:=xlPasteValues
Else
.Range("A3").End(xlDown).Offset(1, 0).PasteSpecial Paste:=xlPasteValues
End If
End If
Application.CutCopyMode = False
End With
Beenden:
Application.Goto Reference:=wks.Range("A1")
Application.ScreenUpdating = True
End Sub

Anzeige
große Klasse! DANKE!
17.12.2017 21:40:57
Kisska
Hallo Franz,
ich wollte dir eigentlich viel früher antworten, aber ich kam leider nicht dazu..
Deine Lösung habe ich getestet und es funktioniert einwandfrei! 1000 Mal Dank dafür! Hätte nicht gedacht, dass man eine Pivot-Tabelle so direkt ansprechen kann.
Danke nochmal und einen schönen Abend noch.
Viele Grüße
Kisska

321 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige