Option Explicit

Sub Zusammenfuegen()
Dim A As Object
Set A = Application
    
    With A
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
        .EnableEvents = False
    End With
 
    Dim DateiName(1 To 2) As String
    Dim Pfad(1 To 2) As String
    Dim I&, J&, lz&, efz&, z&, Offs&, R&, lastR& 'lz=letzte Zeile; efz=erste freie Zeile
    Dim nWB As Workbook, WB As Workbook
    Dim nW As String
    Dim AV, rng As Range, nSh As Worksheet
    Dim NeueDaten, V, Au1$, Au2$, Au3$, Au4$, NewPath$
    
    'set
        Pfad(1) = Workbooks("Makros.xlsm").Path & "\"
        Pfad(2) = Workbooks("Makros.xlsm").Path & "\"
        
        DateiName(1) = "Teil1.xls"
        DateiName(2) = "Teil2.xls"
        Au1 = "Ausschluss1"
        Au2 = "Ausschluss2"
        Au3 = "Ausschluss3"
        Au4 = "Ausschluss4"
        
        Set nWB = Workbooks.Add
        Set nSh = nWB.Sheets(1)
        With nSh
        .Cells(1, 1).Value = "Ü1"
        .Cells(1, 2).Value = "Ü2"
        .Cells(1, 3).Value = "Ü3"
        .Cells(1, 4).Value = "Ü4"
        .Cells(1, 5).Value = "Ü5"
        End With
        ReDim neuedatem(4, 0)
    
    'calc
       For I = 1 To 2
       
           Set WB = Workbooks.Open(Filename:=Pfad(I) & DateiName(I))
           With WB.Sheets(1)
            lz = .Cells(Rows.Count, 5).End(xlUp).Row
            Set rng = .Range(.Cells(1, 1), .Cells(lz, 5))
           End With
           AV = rng.Value
            
           For z = 1 To lz
                V = AV(z + 1, 2)
                If (V <> Au1) _
               And (V <> Au2) _
               And (V <> Au3) _
               And (V <> Au4) Then
    
                   Select Case AV(z + 1, 8)
                        Case Is = "Ü2"
                            Offs = 1
                        Case Is = "Ü3"
                            Offs = 2
                        Case Is = "Ü4"
                            Offs = 3
                        Case Is = "Ü5"
                            Offs = 4
                   End Select
               
                   nW = Left(AV(z + 1, 5), 4) & "00" & Mid(AV(z + 1, 5), 5, 8)
                   If AV(z + 1, 5) = AV(z, 5) Then
                       For I = 0 To efz
                           If NeueDaten(0, I) = nW Then
                               NeueDaten(Offs, I) = NeueDaten(1, I) + AV(z + 1, 13)
                           End If
                       Next
                   Else
                       ReDim Preserve NeueDaten(efz)
                       NeueDaten(1, efz) = nW
                       NeueDaten(Offs + 1, efz) = NeueDaten(Offs + 1, efz) + AV(z + 1, 13)
                       efz = efz + 1
                   End If
                   
               End If
               
               'status bar
                   If R = lastR + 100 Or R = lz Then
                       A.StatusBar = "Zeile: " & R & "/" & lz
                       lastR = R
                   End If
           Next z
           lastR = 0
           WB.Close (False)
           A.StatusBar = "Files: " & I & "/" & 2
       Next I
    
    'transpose
        t = Now()
        transpose NeueDaten
        t = Now() - t
        MsgBox "Fürs transponieren benötigte Zeit: " & Format(t, "ss")
        
    'save
        NewPath = Workbooks("Makros.xlsm").Path & "\" & Format(Date, "YYYYMMDD") & "_Ergebnis.xls"
        With nWB
            With .Sheets(1)
                .Range(.Cells(2, 1), .Cells(efz, UBound(NeueDaten, 2))).Value = NeueDaten
            End With
            .SaveAs Filename:=NewPath
            .Close (False)
        End With
    
        With A
            .ScreenUpdating = True
            .Calculation = xlCalculationAutomatic
            .EnableEvents = True
        End With
        MsgBox "Datei unter " & NewPath & " gespeichert."
        MsgBox "Anzahl der Neudimensionierungen: " & efz
        
End Sub

Private Function transpose(Arr)
Dim R&, C&, S1&, S2&, E1&, E2&
Dim nArr
nArr = Arr

    S1 = LBound(Arr)
    S2 = LBound(Arr, 2)
    E1 = UBound(Arr)
    E2 = UBound(Arr, 2)
    ReDim Arr(S2 To E2, S1 To E1)
    
    For R = S1 To E1
        For C = S2 To E2
            Arr(C, R) = nArr(R, C)
        Next
    Next
    
End Function

Falls du den Code so zum laufen bringst, wie viel Neudimensionierungen werden ausgegeben, wie lange braucht die Transponieren-Funktion?