Inhalt mehrerer Tabellen zusammenführen
21.02.2022 17:25:03
Buddy
Meine Anfrage ist nicht mehr zu finden, deswegen geht es hier weiter.
Das passt soweit. Vielen Dank!
Ich habe in Summe 8 Tabellenreiter. 2 davon, Allg.1 & Allg2, sollen von der Übertragung Ausgeschlossen werden.
Anordnung wie folgt:
Overview|Allg.1|Allg.2|Abt.1|Abt.2|Abt.3|Abt.4|Abt.5
Abt.1-5 sind komplett gleich aufgebaut - Inhalt ist natürlich unterschiedlich.
Des Weiteren sind in allen Abt. Reitern in Spalte A eine Überschrift zu jeder Tabelle - keine zusammengeführten Zellen!
Habe versucht die VBA anzupassen, habe aber leider nein Erfolg gehabt.
________________________________________________________________________
Private Sub CommandButton1_Click()
Dim lRowInOV_Th1&, lRowInOV_Th2&, lRowInOV_Th3&, lRowInOV_Th4&, lRowInOV_Th5&, lLastRowOV&, lLastRowTh1&, lLastRowTh2&, lLastRowTh3&, lLastRowTh4&, lLastRowTh5&, sWksCount&
lRowInOV_Th1 = Sheets(1).Cells(Rows.Count, "B").End(xlUp).Row + 1
lRowInOV_Th2 = Sheets(1).Cells(Rows.Count, "E").End(xlUp).Row + 1
lLastRowOV = lRowInOV_Th1
If lRowInOV_Th2 > lRowInOV_Th1 Then lLastRowOV = lRowInOV_Th2
Range("A4:AG" & lLastRowOV).ClearContents
For sWksCount = 2 To Sheets.Count
With Sheets(sWksCount)
lRowInOV_Th1 = Sheets(1).Cells(Rows.Count, "A").End(xlUp).Row + 1
lRowInOV_Th2 = Sheets(1).Cells(Rows.Count, "E").End(xlUp).Row + 1
lRowInOV_Th3 = Sheets(1).Cells(Rows.Count, "I").End(xlUp).Row + 1
lRowInOV_Th4 = Sheets(1).Cells(Rows.Count, "S").End(xlUp).Row + 1
lRowInOV_Th5 = Sheets(1).Cells(Rows.Count, "AC").End(xlUp).Row + 1
'* Thema1
lLastRowTh1 = .Cells(Rows.Count, "C").End(xlUp).Row
.Range("A3:C" & lLastRowTh1).Copy
Sheets(1).Range("A" & lRowInOV_Th1).PasteSpecial xlPasteValues
'* Thema2
lLastRowTh2 = .Cells(Rows.Count, "E").End(xlUp).Row
.Range("E3:G" & lLastRowTh2).Copy
Sheets(1).Range("E" & lRowInOV_Th2).PasteSpecial xlPasteValues
'* Thema3
lLastRowTh3 = .Cells(Rows.Count, "I").End(xlUp).Row
.Range("I3:Q" & lLastRowTh3).Copy
Sheets(1).Range("I" & lRowInOV_Th3).PasteSpecial xlPasteValues
'* Thema4
lLastRowTh4 = .Cells(Rows.Count, "S").End(xlUp).Row
.Range("S3:AA" & lLastRowTh4).Copy
Sheets(1).Range("S" & lRowInOV_Th4).PasteSpecial xlPasteValues
'* Thema5
lLastRowTh5 = .Cells(Rows.Count, "AC").End(xlUp).Row
.Range("AC3:AG" & lLastRowTh5).Copy
Sheets(1).Range("AC" & lRowInOV_Th5).PasteSpecial xlPasteValues
End With
Application.CutCopyMode = False
Next sWksCount
End Sub
