Innerhalb bestehender Excel Datei bestimmte Tabellenblätter per VBA zusammenfügen

Hallo,

irgendwie komme ich hier nicht weiter,

ich habe eine Excel Datei mit x Tabellenblättern ,

hiervon möchte ich bestimmte Tabellenlätter z.b. Test1 Test6 Test8 & Test12 in ein neues z.b. Test21 zusammenfügen.

In den Tabellen ist jeweils Spaltenüberschrift + 1 Leerzeile und erst darauffolgend Werte vorhanden.
Diese möchte ich nun im Sheet 21 zusammengefügt haben, so das nur 1x die Überschrift der Zeile 1 aus Blatt Test1 gefolgt von allen Datensätzen zusammengefasst werden,
die Blätter haben alle den selben Aufbau (Spalten) nur unterschiedliche Anzahl von Zeilen. Vorhandene Leerzeilen sollten gleichzeitig entfernt werden.

Wie bekomme ich dieses am besten per VBA hin?

Grüße aus München
Thomas

Bitte markiere auch die Kommentare, die zur Lösung des Beitrags beigetragen haben

Content-ID: 318420

Url: https://administrator.de/forum/innerhalb-bestehender-excel-datei-bestimmte-tabellenblaetter-per-vba-zusammenfuegen-318420.html

Ausgedruckt am: 23.12.2024 um 01:12 Uhr

1 Kommentar

Hallo Thomas,
habe ich hier zwar schon öfter gezeigt (Das nächste mal bitte die Suche etwas ausführlicher benutzen), aber hier nochmal, damit die Trefferquote in Zukunft wieder steigt

Variablen zu Beginn anpassen (Quell-Sheets und Zielsheet)

Sub MergeData()
    Dim arrSheets As Variant, intOffset As Integer, rngEmpty As Range, ws as Variant
    ' Name des Tabellenblattes in dem die Daten zusammengefasst werden  
    Const TARGET = "Merged"  
    ' Name der Tabellenblätter im Array auflisten  
    arrSheets = Array("Tab1", "Tab3")  
    
    With Sheets(TARGET)
        'Blatt hat bereits Inhalt ? Setze Offset für Überschriften  
        intOffset = IIf(.Range("A1").Value <> "", 1, 0)  
        'Alle Sheets im Array verarbeiten und Daten kopieren  
        For Each ws In arrSheets
            Sheets(ws).UsedRange.Offset(intOffset, 0).Copy Destination:=.Cells(Rows.Count, "A").End(xlUp).Offset(intOffset, 0)  
            intOffset = 1
        Next
        'Leere Zeilen löschen  
        For Each cell In .Range("A1:A" & .Cells(Rows.Count, "A").End(xlUp).Row)  
            If cell.Value = "" Then  
                If rngEmpty Is Nothing Then
                    Set rngEmpty = cell.EntireRow
                Else
                    Set rngEmpty = Union(rngEmpty, cell.EntireRow)
                End If
            End If
        Next
        If Not rngEmpty Is Nothing Then
            rngEmpty.Delete
        End If
    End With
End Sub