Hallo Karl-Heinz, 

vielen lieben Dank für deine Überarbeitungen! Das funktioniert jetzt gut und ich kann jetzt das Verzeichnis auswählen, wo die xls Dateien liegen, welche zusammengeführt werden sollen.

Aber leider wird dann nicht hinterher eine neue xls Datei "ausgespuckt", die diese kummulierten Daten zeigt...so wie es in der Vergangenheit war.

Hast jemand hier eine Idee?

Gruss

Eugen

Dies ist der Code dazu

Option Explicit
'Outright (Range zu uebertragen A3:Q55)
'2nd Ring (Range B4:X47)
'Carries (Range A3:W28)
'Options (Range A3:N21)
Dim sPath
Sub ZusammenFuehren()
Dim sDir$, ArFile(), i%
Dim ArTabellen(), ArRange(), ArHeader()
Dim n&, nn&
Dim NewWB As Workbook, rngHelp As Range

ArTabellen = Array("Outright", "2nd Ring", "Carries", "Options")
ArRange = Array("A3:Q63", "B4:X59", "A3:W28", "A3:N21")
ArHeader = Array("A1:Q2", "B1:X3", "A1:W2", "A1:N2")

If sPath = "" Then
    sPath = fncGetFolder(, ThisWorkbook.Path)
Else
    sPath = fncGetFolder(, sPath)
End If
If sPath = "" Then Exit Sub
If Right$(sPath, 1) <> "\" Then sPath = sPath & "\"

ChDrive sPath
ChDir sPath

sDir = Dir$(sPath & "????-??-??.xlsx", vbNormal)
Do While sDir <> ""
    i = i + 1
    ReDim Preserve ArFile(1 To 2, 1 To i)
    ArFile(1, i) = sPath & sDir
    ArFile(2, i) = sDir
    sDir = Dir$()
Loop

If i > 0 Then
    On Error GoTo ErrorHandler:
    Call Events_(False)
    'neue Mappe
    Set NewWB = Application.Workbooks.Add
    'Tabellen erstellen
    With NewWB
        For n = LBound(ArTabellen) To UBound(ArTabellen)
            NewWB.Worksheets.Add After:=.Sheets(.Sheets.Count)
            .Sheets(.Sheets.Count).Name = ArTabellen(n)
        Next n
        For n = .Sheets.Count - UBound(ArTabellen) - 1 To 1 Step -1
            .Sheets(n).Delete
        Next n
    End With
    
    For i = 1 To UBound(ArFile, 2)
        Application.StatusBar = "File: " & i & " von " & UBound(ArFile, 2) & " - " & ArFile(2, i)
        With Workbooks.Open(ArFile(1, i), ReadOnly:=True)
            For n = LBound(ArTabellen) To UBound(ArTabellen)
                With .Worksheets(ArTabellen(n))
                    
                    If i = 1 Then
                        Set rngHelp = NewWB.Worksheets(ArTabellen(n)).Range(ArHeader(n))
                        .Range(ArHeader(n)).Copy rngHelp
                        rngHelp.Value = rngHelp.Value
                    End If

                    nn = FindLetzte(NewWB.Worksheets(ArTabellen(n)).Columns(.Range(ArHeader(n)).Columns(1).Column)).Row + 1

                    Set rngHelp = NewWB.Worksheets(ArTabellen(n)).Cells(nn, .Range(ArRange(n)).Columns(1).Column)
                    Set rngHelp = rngHelp.Resize(.Range(ArRange(n)).Rows.Count, .Range(ArRange(n)).Columns.Count)
                    .Range(ArRange(n)).Copy rngHelp
                     rngHelp.Value = rngHelp.Value
                     
                     
                    With NewWB.Worksheets(ArTabellen(n))
                        nn = FindLetzte(NewWB.Worksheets(ArTabellen(n)).Columns(.Range(ArRange(n)).Columns(1).Column)).Row + 1
                        .Range(.Cells(nn, 1), .Cells(.Rows.Count, 1)).EntireRow.Delete
                        .UsedRange.EntireColumn.AutoFit
                    End With
                    
                End With
            Next n
            .Close False
        End With
    Next i
ErrorHandler:
    Call Events_(True)
    Application.StatusBar = False
End If

If Err.Number <> 0 Then
    MsgBox Err.Description, _
           vbCritical + vbMsgBoxSetForeground + vbMsgBoxHelpButton, _
           "Error: " & Err.Number, Err.HelpFile, Err.HelpContext
End If
End Sub

Sub Events_(booschalter As Boolean)
With Application
    .ScreenUpdating = booschalter
    .DisplayAlerts = booschalter
    .EnableEvents = booschalter
    .Calculation = IIf(booschalter, xlCalculationAutomatic, xlCalculationManual)
End With
End Sub

Function FindLetzte(rngBereich As Range) As Range
Dim LRow As Long, LCol As Long
Dim A As Long
 
With rngBereich
    On Error Resume Next
    'Finde Zeile
    LRow = .Find("*", , xlValues, xlWhole, xlByRows, xlPrevious, False, False).Row
    LRow = Application.Max(LRow, .Find("*", , xlFormulas, xlWhole, xlByRows, xlPrevious).Row)
    If LRow = 0 Then LRow = 1
    LCol = 1
End With

Set FindLetzte = rngBereich.Parent.Cells(LRow, LCol)
End Function