Tabellenblätter zusammen führen
07.02.2020 12:23:31
Matthias
ich habe hier einen Code gefunden der vom Grundsatz genaus das macht was ich brauche.
Allerdings scheitere ich an der Anpassung.
Bei mir stehen die Überschriften in Zeile 15. Ab Zeile 16 kommen die Daten
Das Tabellenblatt "AlleDaten" ist vorhanden.
Bei der Zusammenführungen sollen die Daten der einzelnen Tabellenblätter in alle Daten ab Zeile 16 eingetragen werden.
Es sollen keine Überschriften gesetzt werden.
Alles was von Zeile 1 bis Zeile 15 in "Alle Daten" steht darf beim zusammenführen nicht gelöscht werden.
Ist warscheinlich nich schwer anzupassen, aber mir fehlen die Progammierkenntnisse.
MfG
Matthias
Sub AlleDaten2()
'Code für ein allgemeines Modul
'*********************************
'Autor: Jürgen Hennekes
'*********************************
'Es werden die Daten aller Tabellenblätter innerhalb einer Datei auf einem neuen Tabellenblatt gelistet.
'In Spalte A wird das Quellblatt gelistet.
'Die Tabellenblätter haben eine Überschrift in Zeile 1 ab A1, die Daten stehen ab Zeile 2
'Die Tabellenblätter haben einen identischen Aufbau ( Anzahl Spalten ). Die Anzahl der Zeilen spielt keine Rolle.
'Ein Tabellenblatt mit dem Namen "AlleDaten" wird, wenn nicht bereits vorhanden, ganz links erstellt.
Dim wks As Worksheet 'Tabelle AlleDaten
Dim intSh As Integer 'Zähler für Tabelle1 bis TabelleX
Dim intLastS As Integer 'Letzte benutzte Spalte in den Tabellen
Dim lngCopyRows As Long 'Anzahl kopierte Zeilen
Dim bln As Boolean
'Prüfung ob Blatt "AlleDaten" bereits vorhanden ist.
For intSh = 1 To ActiveWorkbook.Worksheets.Count
If Worksheets(intSh).Name = "AlleDaten" Then
Set wks = Worksheets("AlleDaten")
bln = True
Exit For
End If
Next
'Falls nicht vorhanden dann erstellen
If bln = False Then
Set wks = Worksheets.Add
wks.Name = "AlleDaten"
End If
'Blatt AlleDaten nach links schieben
wks.Move Before:=Sheets(1)
'Daten auf Blatt "AlleDaten" löschen und die Überschrift aus Tabelle1 holen
'Anzahl der Spalten zählen. Gilt dann für alle Blätter da Aufbau identisch sein muss
wks.Cells.ClearContents
wks.Range("A1").Value = "Tabellenname"
Worksheets(2).Range("A1:IU1").Copy Destination:=wks.Range("B1")
intLastS = wks.Cells(1, Columns.Count).End(xlToLeft).Column
'Daten aus allen Tabellen nach Tabelle "AlleDaten" übertragen
For intSh = 2 To ActiveWorkbook.Worksheets.Count
With Worksheets(intSh)
.Range(.Cells(2, 1), .Cells(fncLastRow(intSh, intLastS), intLastS)).Copy
wks.Cells(wks.UsedRange.Rows.Count, 2).Offset(1, 0).PasteSpecial Paste:=xlValues
lngCopyRows = wks.UsedRange.Rows.Count - Cells(Rows.Count, 1).End(xlUp).Row
wks.Range("A" & wks.Cells(Rows.Count, 1).End(xlUp).Row + 1).Resize(lngCopyRows) = Worksheets(intSh).Name
End With
Next
Application.CutCopyMode = False
MsgBox "Die Daten aus " & intSh - 2 & " Tabellenblättern wurden gelistet.", 64
End Sub
Public Function fncLastRow(ByVal intSh As Integer, intLastS As Integer) As Long
Dim intS As Integer
With Worksheets(intSh)
For intS = 1 To intLastS
If .Cells(Rows.Count, intS).End(xlUp).Row > fncLastRow Then
fncLastRow = .Cells(Rows.Count, intS).End(xlUp).Row
End If
Next
End With
End Function
Anzeige