Hallo,

es mussten folgende Änderungen vorgenommen werden:

        With Tabelle1.Range("A1")
            .Formula = "=LOOKUP(2,1/('" & sPfad & "[" & sDatei & "]Tabelle1'!$C:$C<>""""),ROW('" & sPfad & "\[" & sDatei & "]Tabelle1'!$C:$C))-9"
            lngLZ = .Value
        End With

In der Formula Zeile muss die Angabe $A:$A nach $C:$C geändert werden.

Zusätzlich müssen die ersten 9 Zeilen abgezogen werden. Daher "-9" am Ende.

            If blnÜberschrift Then
                .Cells(.Rows.Count, 1).End(xlUp).Offset(1).Resize(lngLZ - 1, 5).Formula = _
                "='" & sPfad & "[" & sDatei & "]Tabelle1'!C11"
            Else
                blnÜberschrift = True
                .Cells(.Rows.Count, 1).End(xlUp).Offset(1).Resize(lngLZ, 5).Formula = _
                "='" & sPfad & "[" & sDatei & "]Tabelle1'!C10"
            End If

In diesem Bereich müssen nur zwei Änderungen vorgenommen werden:

Daten: 'Tabelle1'!A2 muss nach 'Tabelle1'!C11 geändert werden

Überschrift: 'Tabelle1'!A1 muss nach 'Tabelle1'!C10 geändert werden.

Der neue Code schaut nach den Änderungen wie folgt aus:

Sub Zusammenführen()
    Dim i               As Long
    Dim sPfad           As String
    Dim sDatei          As String
    Dim vFileToOpen     As Variant
    Dim lngLZ           As Long
    Dim blnÜberschrift  As Boolean
    Dim iCalc           As Integer
    
    
    vFileToOpen = Application.GetOpenFilename("Excel Files (*.xls*), *.xls*", , , , True)
    If Not IsArray(vFileToOpen) Then Exit Sub
    
        
    iCalc = Application.Calculation

    On Error GoTo ENDE:
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False
    
    
    For i = 1 To UBound(vFileToOpen)
        sDatei = Dir(vFileToOpen(i))
        sPfad = Left(vFileToOpen(i), InStr(vFileToOpen(i), sDatei) - 1)
    
        With Tabelle1.Range("A1")
            .Formula = "=LOOKUP(2,1/('" & sPfad & "[" & sDatei & "]Tabelle1'!$C:$C<>""""),ROW('" & sPfad & "\[" & sDatei & "]Tabelle1'!$C:$C))-9"
            lngLZ = .Value
        End With
        
        With Tabelle1
            If blnÜberschrift Then
                .Cells(.Rows.Count, 1).End(xlUp).Offset(1).Resize(lngLZ - 1, 5).Formula = _
                "='" & sPfad & "[" & sDatei & "]Tabelle1'!C11"
            Else
                blnÜberschrift = True
                .Cells(.Rows.Count, 1).End(xlUp).Offset(1).Resize(lngLZ, 5).Formula = _
                "='" & sPfad & "[" & sDatei & "]Tabelle1'!C10"
            End If
        End With
        
        Call StatusBalken(Int((i / UBound(vFileToOpen)) * 100))
    Next
    
    With Tabelle1.UsedRange
        .Copy
        .PasteSpecial xlPasteValues
        .Rows(1).Delete
    End With
    
ENDE:
    Application.EnableEvents = True
    Application.Calculation = iCalc
    Application.ScreenUpdating = True
    If Err Then MsgBox Err.Description, , "Fehler: " & Err
End Sub

Sub StatusBalken(ProzentSatz) ''ProzentSatz = Int((i / 10000) * 100)
    Dim Mess, Z, Rest
    Static oldStatusBar As Integer
    Static blnInit As Boolean

    If Not blnInit Then
        oldStatusBar = Application.DisplayStatusBar
        Application.DisplayStatusBar = True
    End If
    
    Mess = ""
    For Z = 1 To ProzentSatz
        Mess = Mess & ChrW(Val("&H25A0"))
    Next Z
    Rest = 100 - ProzentSatz
    For Z = 1 To Rest
        Mess = Mess & ChrW(Val("&H25A1"))
    Next Z
    Application.StatusBar = Mess & " " & ProzentSatz & "%"
    
    If Rest <= 0 Then
        Application.StatusBar = False
        Application.DisplayStatusBar = oldStatusBar
    End If
End Sub

Während der Ausführung ist mir aufgefallen, dass nur die ersten 5 Überschriften importiert werden, obwohl in den Daten 30 Überschriften vorhanden sind.

LG, BigBen