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'!$A:$A<>""""),ROW('" _
 _
 & sPfad & "\[" & sDatei & "]Tabelle1'!$A:$A))"
            lngLZ = .Value
        End With
 
        With Tabelle1
            If blnÜberschrift Then
                .Cells(.Rows.Count, 1).End(xlUp).Offset(1).Resize(lngLZ - 1, _
                  7).Formula = _
                "='" & sPfad & "[" & sDatei & "]Tabelle1'!A2"
            Else
                blnÜberschrift = True
                .Cells(.Rows.Count, 1).End(xlUp).Offset(1).Resize(lngLZ, _
                  7).Formula = _
                "='" & sPfad & "[" & sDatei & "]Tabelle1'!A1"
            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