VBA für Excel zum Zusammenführen von Tabellen in Blättern

Option Explicit

Const ListDaten = "Alle Daten"  'Tabellenblatt Alle Daten  

Const CopyRng = "D9"            'Kopieren Zelle 1  
Const CopyBeg = "D"             'Kopieren Spalte 1  
Const CopyEnd = "H"             'Kopieren Spalte n  

Const ListId = "A"              'Alle Daten Spalte Lfd-Nr.  
Const ListName = "B"            'Alle Daten Spalte Tabellenname  
Const ListPaste = "C"           'Alle Daten Spalte Datenkopie  

Sub InitDaten()
    Dim Wks As Worksheet, Found As Object, NextLine As Integer, Id As Integer
    
    Call InitListSheet
    
    Application.ScreenUpdating = False
    
    For Each Wks In Worksheets
        If Wks.Name <> ActiveSheet.Name Then
            Set Found = Columns(ListName).Find(Wks.Name, LookIn:=xlValues, LookAt:=xlWhole)
            If Found Is Nothing And Not IsEmpty(Wks.Range(CopyRng)) Then
                NextLine = GetEndLine(ActiveSheet, ListPaste) + 1
                Cells(NextLine, ListId) = GetNextId():  Cells(NextLine, ListName) = Wks.Name
                Range(Wks.Range(CopyRng), Wks.Cells(GetEndLine(Wks, CopyBeg), CopyEnd)).Copy
                ActiveSheet.Paste Destination:=Cells(NextLine, ListPaste)
                Application.CutCopyMode = False
            End If
        End If
    Next
    Application.ScreenUpdating = True
End Sub

Private Sub InitListSheet()
    Dim Wks As Worksheet
    
    On Error Resume Next:  Set Wks = Sheets(ListDaten):  On Error GoTo 0
    
    If Wks Is Nothing Then
        Sheets.Add Before:=Sheets(1):  ActiveSheet.Name = ListDaten
        With Range("A1:G1")  
            .Value = Array("Lfd.-Nr.", "Blattname", "Vorname", "Datum1", "Datum2", "Typ1", "Typ2")  
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlCenter
            .Font.FontStyle = "Fett"  
        End With
    Else
        Wks.Activate
    End If
End Sub

Private Function GetEndLine(ByRef Wks, Col As String) As Integer
    GetEndLine = Wks.Cells(Wks.Rows.Count, Col).End(xlUp).Row
End Function
    
Private Function GetNextId() As Integer
    Dim EndLine As Integer
    EndLine = GetEndLine(ActiveSheet, ListId)
    If EndLine = 1 Then GetNextId = 1 Else GetNextId = Cells(EndLine, ListId) + 1
End Function