Clever-Excel-Forum - VBA-Schleife: Datenbereich kopieren und einfügen

"Hallo Zusammen,

vielleicht ist die Umsetzung nicht besonders schwierig aber ich bin nun mal ein VBA Anfänger.

Ich möchte mit VBA folgendes erreichen:

Ich möchte Daten der PIVOT-Tabelle links kopieren und unter dem aktuellen Datensatz in der Tabelle rechts einfügen.

Das heißt die Schleife muss erst mal den Datenbereich der Pivottabelle abzählen. Spalten bleiben gleich aber die Anzahl der Zeilen ist variabel:
Die erste Zelle unter "Zeilenbeschriftung" und eine Zelle vor "Gesamtergebnis"

Dieser Bereich muss kopiert werden und dann unter der ersten Leeren Zelle in der Spalte Zeilenbeschriftung (Tabelle rechts) eingefügt werden.

Zudem sollen die Formeln der 2 grünen Spalten noch bis zur letzten befüllten Zelle runtergezogen werden und

das heutige Datum in der gelben Spalte jeweils für alle neuen Daten eingefügt werden. (Aber als fester Wert, da die Formel Heute() sich ja täglich ändern würde)

Ich werde mich nun mal an den Code versuchen, bin mir aber sicher dass ich einige Fehler machen werde.

Ich danke schonmal vielmals

Gruß stchwint

Hi

ohne Bsp.Datei hier erst mal nur etwas Hilfe zur Selbsthilfe.

Den Datenbereiche der Pivot kannst du so ermitteln.

Code:
MsgBox PivotTables(1).DataBodyRange.Address

Weitere Hilfe dazu.
https://docs.microsoft.com/de-de/office/...pivottable

Gruß Elex

Also habe eine Beispieldatei im Anhang. Mit Screenshots wie ich es vorher und nach dem makro haben will.

Nämlich sollen im blau markierten Bereich auf dem Bild die Daten der Pivottabelle unten dran gehängt werden, die 2 Formeln der grünen Spalten runterzogen werden und in der gelben Spalte das heutige Datum bis zur neuen befüllten Zeile eingetragen werden.

Hi

Versuch es mal mit dem Code.

Code:
Sub CopyPivot()

Dim rng As Range, j As Long

With Sheets("Gesamt_Vorher")    'Blattnamen anpassen

  j = .Cells(.Rows.Count, 12).End(xlUp).Row + 1

  Set rng = .PivotTables(1).RowRange.Offset(1)

  If .PivotTables(1).ColumnGrand Then

     rng.Resize(rng.Rows.Count - 2, 10).Copy Range("O" & j)

  Else

     rng.Resize(rng.Rows.Count - 1, 10).Copy Range("O" & j)

  End If

   .Range("M2:N" & .Cells(.Rows.Count, 15).End(xlUp).Row).FillDown

   .Range(Cells(j, 12), Cells(.Cells(.Rows.Count, 15).End(xlUp).Row, 12)) = Date

   Set rng = Nothing

End With

End Sub

Gruß Elex