VBA - "Datenbank" aus Einzeltabellen

[Kirschgurke]

Hallo zusammen,

ich komme leider nicht weiter beim zusammenfassen mehrerer Tabellen in einer einzigen. Ich möchte für eine Pivotauswertung die Zellbereiche von A1-AB500 der einzelnen Arbeitsblätter(identischer Aufbau) in einem Blatt zusammenfassen. Falls ich in den einzelnen Datenblättern etwas aktualsiere, soll das Makro dann die "Datenbank" aktualisieren bzw einfach überschreiben.

"Tagesreinigung" -> A1-AB500 / mit Spalten Art Anzahl Kosten...
"Monatsreinigung" -> A1-AB500 / mit Spalten Art Anzahl Koste...
......
"Datenbank" -> zusammenfassung / mit Spalten Art Anzahl Kosten...

Ich hoffe, Ihr könnt mir weiterhelfen.

[Gast 123]

Hallo

anbei ein einfaches Makro mit dem man das Problem mittels GoSub als Unterprogramm lösen kann.  GoSub kann mit jedem weiteren Tabellen Namen beliebig oft aufgerufen werden.  Jeweils mit einstellbarem Abstand in Const Zahl = 500 Zeilen.  Bitte mal ausprobieren ob es so funktioniert.

mfg  Gast 123
 

Code:

Option Explicit      '11.1.2017  Gat 123  Clever Forum

'"Tagesreinigung" -> A1-AB500 / mit Spalten Art Anzahl Kosten...
'"Monatsreinigung" -> A1-AB500 / mit Spalten Art Anzahl Koste...
'"Datenbank" -> zusammenfassung / mit Spalten Art Anzahl Kosten...

Const Zahl = 500   '500 Zeilen nach unten für Next Copy


Sub Datenbank_Tagesreinigung()
Dim xTab As Worksheet, Zeile As Long
Zeile = 1   '1. Zeile zum kopieren

Set xTab = Worksheets("Tagesreinigung")
GoSub cpy   'Copy Unterprogramm

Set xTab = Worksheets("Monatsreinigung")
GoSub cpy   'Copy Unterprogramm

Set xTab = Worksheets("Weitere Tabellen ...")
GoSub cpy   'Copy Unterprogramm
Exit Sub

cpy:  'Unterproramm kopieren
With Worksheets("Datenbank")
  xTab.Range("A1:AB500").Copy
  .Range("A" & Zeile).PasteSpecial xlPasteAll
   Zeile = Zeile + Zahl
   Application.CutCopyMode = False
End With
End Sub

[Kirschgurke]

Vielen Dank! Anbei auch noch meine Lösung:

Sub Datenübertragung()
'Bereich kopieren
Sheets("Auftragsdaten").Range("A2:AA1400").Copy
'einfügen in erste freie Zeile in ausgabe
Sheets("Datenbank").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
'Kopiermodus beenden
Application.CutCopyMode = False
End Sub