Microsoft Excel

Herbers Excel/VBA-Archiv

Daten aus mehreren Sheets zusammenkopieren


Betrifft: Daten aus mehreren Sheets zusammenkopieren von: MatthiasW
Geschrieben am: 06.12.2017 14:16:49

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

  

Betrifft: AW: Hm... von: Fennek
Geschrieben am: 06.12.2017 14:42:29

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


  

Betrifft: AW: Daten aus mehreren Sheets zusammenkopieren von: Werner
Geschrieben am: 06.12.2017 14:49:20

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


  

Betrifft: AW: Daten aus mehreren Sheets zusammenkopieren von: MatthiasW
Geschrieben am: 06.12.2017 15:53:48

@´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!


  

Betrifft: Gerne u. Danke für die Rückmeldung. o.w.T. von: Werner
Geschrieben am: 06.12.2017 15:54:40




Beiträge aus den Excel-Beispielen zum Thema "Daten aus mehreren Sheets zusammenkopieren"