Daten kopieren.

Sub Start()
Dim gesWS As Worksheet, tmpWS As Worksheet
Dim rngData() As Range
Dim n&, MaxRow
Dim sAddress$
On Error GoTo ErrorHandler:
Call Events_(False)
'Daten Sammeln
For Each tmpWS In ThisWorkbook.Worksheets
If IsNumeric(tmpWS.Name) Then
With tmpWS
MaxRow = .Cells(.Rows.Count, 2).End(xlUp).Row
If MaxRow > 1 Then
ReDim Preserve rngData(n)
If .Cells(1, 1).Value  "Zuordnung" Then
.Columns(1).Insert Shift:=xlToRight
.Cells(1, 1).Value = "Zuordnung"
Set rngData(n) = .UsedRange.Rows(2).Resize(MaxRow - 1)
Else
Set rngData(n) = .UsedRange.Rows(2).Resize(MaxRow - 1)
End If
rngData(n).Columns(1).Value = .Name
n = n + 1
End If
End With
End If
Next
'Ausgabe
If n > 0 Then
Set gesWS = CheckTabelle("Gesamt")
If gesWS Is Nothing Then
With ThisWorkbook
Set gesWS = .Worksheets.Add(Before:=.Sheets(1))
gesWS.Name = "Gesamt"
End With
End If
With gesWS
'alte Daten löschen
If .UsedRange.Rows(.UsedRange.Rows.Count).Row > 1 Then
.UsedRange.Cells(2, 1).Resize(.UsedRange.Rows.Count - 1).EntireRow.Delete
End If
For n = LBound(rngData) To UBound(rngData)
MaxRow = .Cells(.Rows.Count, 1).End(xlUp).Row
MaxRow = MaxRow + 1
rngData(n).Copy .Cells(MaxRow, 1)
Next
.UsedRange.Value = .UsedRange.Value
End With
End If
Call Events_(True)
MsgBox "fertig!"
Exit Sub
ErrorHandler:
Call Events_(True)
MsgBox Err.Description, vbCritical, "Fehler: " & Err.Number, Err.HelpFile, Err.HelpContext
End Sub

Function CheckTabelle(strName$) As Worksheet
On Error Resume Next
Set CheckTabelle = ThisWorkbook.Worksheets(strName)
On Error GoTo 0
End Function

Sub Events_(booSchalter As Boolean)
Dim App As Object
Static Calc As XlCalculation
With Application
If Not booSchalter Then Calc = .Calculation
.ScreenUpdating = booSchalter
.DisplayAlerts = booSchalter
.EnableEvents = booSchalter
.Calculation = IIf(booSchalter, Calc, xlCalculationManual)
End With
End Sub