Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
1592to1596
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Daten aus mehreren Sheets zusammenkopieren

Daten aus mehreren Sheets zusammenkopieren
06.12.2017 14:16:49
MatthiasW
Hallo zusammen,
nach eurer erfolgreichen Hilfe von letzter Woche komme ich nun leider wieder nicht weiter. Folgende Aufgabe: Ich möchte die Bereiche A2:ABXX aus aktuell 12 Tabellenblättern in das Sheet Datengrundlage gesamt kopieren. Die Daten sollen alle untereinander in die jeweils nächste Zeile kopiert werden. Mein Code funktioniert auch aktuell. Allerdings mit der Einschränkung, dass durch den aktuellen Kopiervorgang immer der vorherige überschrieben wird. Am Ende wurde also nur der Datenbereich aus dem letzten KST-Sheet übernommen. Ich habe schon mit einer Fornext Schleife gebastelt, lande aber immer wieder im Debugger. Was muss ich tun, damit am Ende alle Daten aus allen 12 Sheets untereinander stehen?
Nachfolgend noch mein Code:
Sub auswählen()
'Variablen Deklaration
Dim nextrow As Long
Dim lastrow1 As Long
Dim lastrow2 As Long
Dim lastrow3 As Long
Dim lastrow4 As Long
Dim lastrow5 As Long
Dim lastrow6 As Long
Dim lastrow7 As Long
Dim lastrow8 As Long
Dim lastrow9 As Long
Dim lastrow10 As Long
Dim lastrow11 As Long
Dim lastrow12 As Long
Dim M01000 As Worksheet
Dim M20000 As Worksheet
Dim M21000 As Worksheet
Dim M25000 As Worksheet
Dim M32210 As Worksheet
Dim M32250 As Worksheet
Dim M51200 As Worksheet
Dim M52400 As Worksheet
Dim M67100 As Worksheet
Dim M69100 As Worksheet
Dim M71000 As Worksheet
Dim M72000 As Worksheet
Dim M73000 As Worksheet
Dim Datengrundlagegesamt As Worksheet
'Variablen zuweisung
Set M01000 = Worksheets("M01000")
Set M20000 = Worksheets("M20000")
Set M21000 = Worksheets("M21000")
Set M25000 = Worksheets("M25000")
Set M32210 = Worksheets("M32210")
Set M32250 = Worksheets("M32250")
Set M51200 = Worksheets("M51200")
Set M52400 = Worksheets("M52400")
Set M67100 = Worksheets("M67100")
Set M69100 = Worksheets("M69100")
Set M71000 = Worksheets("M71000")
Set M72000 = Worksheets("M72000")
Set M73000 = Worksheets("M73000")
Set Datengrundlagegesamt = Worksheets("Datengrundlage gesamt")
nextrow = Datengrundlagegesamt.Range("A65536").End(xlUp).Row + 1
lastrow1 = M01000.Range("A65536").End(xlUp).Row - 2
lastrow2 = M20000.Range("A65536").End(xlUp).Row - 2
lastrow3 = M25000.Range("A65536").End(xlUp).Row - 2
lastrow4 = M32210.Range("A65536").End(xlUp).Row - 2
lastrow5 = M32250.Range("A65536").End(xlUp).Row - 2
lastrow6 = M51200.Range("A65536").End(xlUp).Row - 2
lastrow7 = M52400.Range("A65536").End(xlUp).Row - 2
lastrow8 = M67100.Range("A65536").End(xlUp).Row - 2
lastrow9 = M69100.Range("A65536").End(xlUp).Row - 2
lastrow10 = M71000.Range("A65536").End(xlUp).Row - 2
lastrow11 = M72000.Range("A65536").End(xlUp).Row - 2
lastrow12 = M73000.Range("A65536").End(xlUp).Row - 2
'Kopieren und Einfügen von Daten M01000
M01000.Activate
M01000.Range(Cells(7, 1), Cells(lastrow1, 28)).Copy
Datengrundlagegesamt.Cells(Rows.Count + 1, 1).PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
'Kopieren und Einfügen von Daten M20000
M20000.Activate
M20000.Range(Cells(7, 1), Cells(lastrow2, 28)).Copy
Datengrundlagegesamt.Cells(nextrow, 1).PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
'Kopieren und Einfügen von Daten M25000
M25000.Activate
M25000.Range(Cells(7, 1), Cells(lastrow3, 28)).Copy
Datengrundlagegesamt.Cells(nextrow, 1).PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
'Kopieren und Einfügen von Daten M32210
M32210.Activate
M32210.Range(Cells(7, 1), Cells(lastrow4, 28)).Copy
Datengrundlagegesamt.Cells(nextrow, 1).PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
'Kopieren und Einfügen von Daten M32250
M32250.Activate
M32250.Range(Cells(7, 1), Cells(lastrow4, 28)).Copy
Datengrundlagegesamt.Cells(nextrow, 1).PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
'Kopieren und Einfügen von Daten M51200
M51200.Activate
M51200.Range(Cells(7, 1), Cells(lastrow4, 28)).Copy
Datengrundlagegesamt.Cells(nextrow, 1).PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
'Kopieren und Einfügen von Daten M52400
M52400.Activate
M52400.Range(Cells(7, 1), Cells(lastrow4, 28)).Copy
Datengrundlagegesamt.Cells(nextrow, 1).PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
'Kopieren und Einfügen von Daten M67100
M67100.Activate
M67100.Range(Cells(7, 1), Cells(lastrow4, 28)).Copy
Datengrundlagegesamt.Cells(nextrow, 1).PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
'Kopieren und Einfügen von Daten M69100
M69100.Activate
M69100.Range(Cells(7, 1), Cells(lastrow4, 28)).Copy
Datengrundlagegesamt.Cells(nextrow, 1).PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
'Kopieren und Einfügen von Daten M71000
M71000.Activate
M71000.Range(Cells(7, 1), Cells(lastrow4, 28)).Copy
Datengrundlagegesamt.Cells(nextrow, 1).PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
'Kopieren und Einfügen von Daten M72000
M72000.Activate
M72000.Range(Cells(7, 1), Cells(lastrow4, 28)).Copy
Datengrundlagegesamt.Cells(nextrow, 1).PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
'Kopieren und Einfügen von Daten M73000
M73000.Activate
M73000.Range(Cells(7, 1), Cells(lastrow4, 28)).Copy
Datengrundlagegesamt.Cells(nextrow, 1).PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
End Sub
Wie ihr sehen könnt, bin ich noch recht grün hinter meinen VBA Ohren und aus diesem Grund für jeden Tipp dankbar. Vielleicht hat auch jemand eine Idee, wie ich meinen Code kürzer schreiben kann? Besten Dank vorab!
Grüße
Matthias

4
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Hm...
06.12.2017 14:42:29
Fennek
Hallo,
den folgenden Code habe ich einfach runtergeschrieben, d.h. es dürften viele Fehler drin sein. Das Debuggen ist aber das wichtigste Lernziel:

for each WS in sheets
if WS.name  "Datengrundlagegesamt" then
lr = .cells(rows.count,1).end(xlup).row
lrD = sheets("Datengrundlagegesamt").cells(rows.count, 1).end(xlup).row + 1
.range(.cells(7,1), .cells(lr, 28)).copy sheets("Datengrundlagegesamt").cells(lrD,1)
end if
next WS
mfg
AW: Daten aus mehreren Sheets zusammenkopieren
06.12.2017 14:49:20
Werner
Hallo Matthias,
ich habe jetzt mal die einzelnen Blattnamen explicit so in den Code aufgenommen, weil ich nicht weiß, was du sonst noch für Blätter in der Datei hast.
Wenn es nur 2 oder 3 weitere Blätter sind, die nicht in die Auswertung mit rein sollen, dann ist die Methode von Fennek, diese Blätter auszuschließen, besser.
Public Sub aaa()
Dim wsQuelle As Worksheet, wsZiel As Worksheet
Dim loQuelle As Long, loZiel As Long
Set wsZiel = Worksheets("Datengrundlage gesamt")
For Each wsQuelle In ThisWorkbook.Worksheets
Select Case wsQuelle.Name
Case "M01000", "M20000", "M21000", "M25000", "M32210", "M32250", "M51200" _
, "M52400", "M67100", "M69100", "M71000", "M72000", "M73000"
'letzte Zeile im Quellblatt ermitteln -2
loQuelle = wsQuelle.Cells(wsQuelle.Rows.Count, 1).End(xlUp).Row - 2
'letzte Zeile im Zielblatt ermitteln +1
loZiel = wsZiel.Cells(wsZiel.Rows.Count, 1).End(xlUp).Row + 1
wsQuelle.Range(wsQuelle.Cells(7, 1), wsQuelle.Cells(loQuelle, 28)).Copy
wsZiel.Cells(loZiel, 1).PasteSpecial Paste:=xlValues
Case Else
End Select
Next wsQuelle
Application.CutCopyMode = False
Set wsZiel = Nothing
End Sub
Gruß Werner
Anzeige
AW: Daten aus mehreren Sheets zusammenkopieren
06.12.2017 15:53:48
MatthiasW
@´Fennek und Werner: Vielen Dank euch beiden, für die schnelle Lösung meines Problems. Ich habe mich zunächst für Werners Lösung entschieden. Funktioniert wunderbar!
Gerne u. Danke für die Rückmeldung. o.w.T.
06.12.2017 15:54:40
Werner

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige