Inhalt mehrere Tabellenblätter in ein "großes" Tabellenblatt kopieren.

[dantri81]

Hallo zusammen,

ich möchte den Inhalt (Werte) mehrerer von mir definierten Tabellenblätter (alles in einer Arbeitsmappe) per Makro in ein einziges "großes" Tabellenblatt kopieren.

Der Spaltenbereich geht immer von A bis N. Der Zeilenbereich kann beliebig lang sein.

Dieses Makro soll es allerdings in zwei Varianten geben.

Variante 1:
Es werden alle Zeilen aus den von mir definierten Tabellenblättern untereinander in das "große" Tabellenblatt kopiert.

Variante 2:
In Spalte D steht in jedem Tabellenblatt die Artikelnummer eines Produktes. Diese Nummer kann allerdings in dem jeweiligen Tabellenblatt, aber auch in anderen Tabellenblättern, mehrfach vorkommen.
Das Makro soll nun aber jede Artikelnummer nur einmal in das "große" Tabellenblatt kopieren und die Dubletten ignorieren.

Kriegt das einer von Euch irgendwie hin? 
Das wäre spitzenmäßig

vg
Daniel

[Gast 123]

Hallo Daniel,

anbei ein Code der aus drei Einzel Makros besteht. Die 1. Variante ist das Makro:  "Sub Tabellen_Kopieren"

Bevor du es laufen laesst must du zuerst in der Const Anweisung den Namen -deiner Zieltabelle- (grosse Tabelle) angeben. Sonst funktioniert es nicht! Weiter must du im Makro selbst die "Quelltabellen" angeben. Zur Zeit sind es drei mit Namen: "Tabelle 1, 2, 3" Du kannst den Code beliebig erweitern. 

Wenn du einen Button verwendest nimm das 1. Makro zum kopieren mit anschliessend sortieren und doppelte löschen. Dazu sortiert das Makro zweimal. zuerst alle Daten vor dem löschen, dann werden doppelte gelöscht, und noch mal neu sortiert. Man könnte auch doppelte durch Suchen finden, ist aber aufwendiger. So ist es einfacher

Probiere den Code bitte zuerst in einer Testdatei aus, bitte nicht mit Originaldaten.  Er ist nicht getestet.

mfg  Gast 123

Code:

Option Explicit      '14.12.2016  Gast 123  Clever Forum

Const ZielTab = "Zieltabelle"  'hier Name der Zieltabeel von Hand einsetzen


'alle Tabellen kopieren

'** Button dieses Makro zuweisen. Hier werden alle Makros ausgeführt.
Sub alle_Tabellen_kopieren()
  Call Tabellen_Kopieren
  Call doppelte_löschen
End Sub



Sub Tabellen_Kopieren()
Dim Qtab As Worksheet   'Quell Tabellen
Dim Ztab As Worksheet   'Ziel Tabelle
Dim qlz As Long, zlz As Long  'LastZell
'hier Name der Zieltabelle eintragen
Set Ztab = Worksheets(ZielTab)

'** hier Namen aller Quelltabellen eintragen
Qtab = Worksheets("Rabelle1")
GoSub Cpy  'Kopier Programm
Qtab = Worksheets("Rabelle2")
GoSub Cpy
Qtab = Worksheets("Rabelle3")
GoSub Cpy
Exit Sub  'Programm Ende

Cpy:  'Sub-Programm
  'zuerst LastZell in Quelle ermitteln
  qlz = Qtab.Cells(Rows.Count, "A").End(xlUp).Row
  zlz = Ztab.Cells(Rows.Count, "A").End(xlUp).Row + 1
 
  Qtab.Range("A2:N" & qlz).Copy
  Ztab.Range("A2:A" & zlz).PasteSpecial xlPasteAll
  Application.CutCopyMode = False
End Sub



Sub doppelte_löschen()
Dim Ztab As Worksheet, zlz As Long
Set Ztab = Worksheets(ZielTab)
  Call Sortieren
  zlz = Ztab.Cells(Rows.Count, "A").End(xlUp).Row
 
For Each AC In Ztab.Range("A2:A" & zlz)
 If AC.Offset(1, 0) = AC.Value Then AC.Resize(1, 14) = Empty
Next AC
  Call Sortieren
End Sub



Sub Sortieren()
Dim Ztab As Worksheet, zlz As Long
Set Ztab = Worksheets(ZielTab)
  zlz = Ztab.Cells(Rows.Count, "A").End(xlUp).Row
  Ztab.Range("A2:N" & zlz).sort Key1:=Range("A2"), Order1:=xlAscending, _
     Header:=xlNo, OrderCustom:=1, MatchCase:=True, Orientation:= _
     xlTopToBottom, DataOption1:=xlSortNormal
End Sub

[dantri81]

Danke sehr! Das passt so!