Hallo,

Den Statusbar kannst du mit "DoEvents" aktualisieren. Freigeben kannst du den, wenn du willst. Ich lass ihn ganz gerne so, weil ich mir noch ganz gerne später Laufzeiten, Zähler etc. angucke.

60000 * redim preserve kostet schon ein paar Sekunden. Hab den Code nochmal ein bisschen geändert, sollte jetzt so ziehmlich mit optimaler Geschwindigkeit laufen (Nurnoch 3 * redim preserve, geringere Update-Frequenz für den Statusbar, Variable nW als Double und ohne Val() Funktion, sollte das Gleiche bei rauskommen). Du kannst auch noch Select Case durch eine If-Funktion ersetzen, macht das Ganze noch ein ganz klein bisschen schneller, aber weniger übersichtlich.

Noch was zu Arrays, String Arrays sind bei Textoperationen am schnellsten, numerische bei Rechenoperationen und Variants bei einer Mischung aus beidem. Mit Strings rechnen ist nicht effizient.

Ach ja, müsste Zeile 70 nicht "For y = 1 To efz             '-1 aufgrund Nutzung Array-Zeile 0" lauten?

Hier nochmal meine Version:

Option Explicit
 
Sub Zusammenfuegen()
'Bildschirmaktualisierung etc. abschalten, um Zeit zu sparen
    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
        .EnableEvents = False
    End With
 
'Variablen
    Dim DateiName(1 To 2) As String, Pfad(1 To 2) As String, nW As Double, SpeichernUnter As String
    Dim I&, offs&, z&, y&, lz&, efz&, lastR&
    Dim nWB As Workbook, WB As Workbook, nSh As Worksheet, rng As Range
    Dim AV, NeueDaten()
     
'Pfade+Dateinamen festlegen
    Pfad(1) = "\"
    Pfad(2) = "\"
    DateiName(1) = "Teil1.xls"
    DateiName(2) = "Teil2.xls"
        
'Überschriften in "Spalte" 0 des Arrays
    ReDim NeueDaten(4, 0)
    NeueDaten(0, 0) = "X"
    NeueDaten(1, 0) = "XX"
    NeueDaten(2, 0) = "XXX"
    NeueDaten(3, 0) = "XXXX"
    NeueDaten(4, 0) = "XXXXX"
 
    efz = 1
 
'Schleife über Dateien
    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, 13)) 'hier wurden sehr
                'viele Daten ausgelesen, aber Spalte 13 wird benötigt!
                'Teile auslesen statt gesamtem Bereich? Spalten 2,5,8,13 relevant
                'und später benötigt
                 
            AV = .Range(.Cells(1, 1), .Cells(lz, 13)).Value
        End With
        
        ReDim Preserve NeueDaten(4, UBound(NeueDaten, 2) + lz - 2) 'neudimensionieren
        lastR = 0
        
    'Schleife über Zeilen der Datei i
        For z = 2 To lz                 'Start bei Zeile 2 wg. Überschriften
         
        'Ausschlusskriterien prüfen (Spalte 2)
            If (AV(z, 2) <> "A") And (AV(z, 2) <> "AA") And _
            (AV(z, 2) <> "AAA") And (AV(z, 2) <> "AAAA") Then
                 
               'Offset bestimmen (nach Spalte 8)
                Select Case AV(z, 8)
                        Case Is = "XX"
                            offs = 1
                        Case Is = "XXX"
                            offs = 2
                        Case Is = "XXXX"
                            offs = 3
                        Case Is = "XXXXX"
                            offs = 4
                End Select
                 
               'nW enthält #, "00" eingefügt
                nW = Mid(AV(z, 5), 1, 4) & "00" & Mid(AV(z, 5), 5, 8) 'Double als Dateityp statt string und Val(), gleiches Ergebnis?
                 
                'prüfen ob # schon vorhanden, dann aufaddieren, sonst neue Spalte
                If AV(z, 5) = AV(z - 1, 5) Then
                    For y = 1 To efz             '-1 aufgrund Nutzung Array-Zeile 0, nicht eher start wert + 1?
                        If NeueDaten(0, y) = nW Then
                             NeueDaten(offs, y) = NeueDaten(offs, y) + AV(z, 13)
                        End If
                    Next
                Else
                    NeueDaten(0, efz) = nW                  'Zeile 0 = Überschrift
                    NeueDaten(offs, efz) = AV(z, 13)        'nicht alter Wert + neuer Wert, da Alter nicht vorhanden
                                                            'und Indexfehler bei Ansteuerung des Arrays
                    efz = efz + 1
                End If
            End If
             
        'status bar
            If z = lastR + 1000 Or z = lz Then
                Application.StatusBar = "Zeile: " & z & "/" & lz
                DoEvents
                lastR = z
            End If
        Next z
        WB.Close (False)
        Application.StatusBar = "Datei " & I & "/" & 2 & " erledigt."
        DoEvents
    Next I
     
    'Transponieren
        ReDim Preserve NeueDaten(4, efz - 1)      'array kürzen
        transpose NeueDaten

    'Speichern in neuer Datei
    SpeichernUnter = ThisWorkbook.Path & "\" & _
        Format(Date, "YYYYMMDD") & "_" & Format(Time, "HHMMSS") & "_Ergebnis.xls"
    Set nWB = Workbooks.Add
        With nWB
            With .Sheets(1)
            'Daten einfügen
                .Range(.Cells(1, 1), .Cells(efz, UBound(NeueDaten, 2) + 1)).Value = NeueDaten
            'sortieren
                .Range(.Cells(1, 1), .Cells(efz, UBound(NeueDaten, 2) + 1)).Sort Key1:=Range("A2"), _
                Order1:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:=False, _
                Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
            End With
        .SaveAs Filename:=SpeichernUnter
        .Close (False)
    End With
    Workbooks("Makros.xls").Sheets(1).Cells(10, 2).Value = "Gespeichert unter: " & SpeichernUnter
 
    With Application
        .ScreenUpdating = True
        .Calculation = xlCalculationAutomatic
        .EnableEvents = True
        .StatusBar = False
    End With
 
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 C
    Next R
End Function