Hallo nochmal,

nach weiteren Anpassungen ist noch ein kleines Problem aufgekommen:

Die Statusbarkiste finde ich gut. Wenn aber die Bildschirmaktualisierung ausgeschaltet ist stoppt der Zähler in dem Moment, in dem etwas "über der Statusbar" landet.

Kann man die Bildschirmaktualisierung für die Statusbar aktiv lassen? Wenn die erste XLS geöffnet wird, scheint das neue Fenster halt die Bar zu verdecken, woraufhin dise sich nicht mehr aktualisiert und einfriert...Oder liegt es an etwas anderem? Ich habe die eh schon bestehende Zählvariable z für die Statusbar genutzt, anstelle der R.

Das da im Hintergrund die beiden Teildateien geöffnet werden, möchte ich aber auch nicht anzeigen :-)

Es empfiehlt sich (wie ich las) die Statusleiste am Ende wieder freizugeben.

Application.StatusBar = False

Hier der Code:

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 String, SpeichernUnter As String
    Dim i&, offs&, z&, y&, lz&, efz&, lastR&
    Dim nWB 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
        Workbooks.Open Filename:=Pfad(i) & DateiName(i)
        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
        
        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 = Val(Mid(AV(z, 5), 1, 4) & "00" & Mid(AV(z, 5), 5, 8))
                
                'prüfen ob # schon vorhanden, dann aufaddieren, sonst neue Spalte
                If AV(z, 5) = AV(z - 1, 5) Then
                    For y = 0 To efz - 1            '-1 aufgrund Nutzung Array-Zeile 0
                        If NeueDaten(0, y) = nW Then
                             NeueDaten(offs, y) = NeueDaten(offs, y) + AV(z, 13)
                        End If
                    Next
                Else
                    ReDim Preserve NeueDaten(4, efz)        'eine Spalte anfügen
                    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 + 50 Or z = lz Then
                Application.StatusBar = "Zeile: " & z & "/" & lz
                lastR = z
            End If
        Next z
        Workbooks(DateiName(i)).Close (False)
        Application.StatusBar = "Datei " & i & "/" & 2 & " erledigt."
    Next i
    
    'Transponieren
    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