Hi Muri,

Hier mal ein Code, der

1) alle Exceldateien im Ordner oder Unterordner durchsucht

2) diese Öffnet

3) den zusammenhängenden Bereich ab A1 kopiert

4) in einem zuvor definierten Mastersheet kopiert bzw unten anhängt

Hinweis:

Es sind diverse Bedingungen in dem Code deaktiviert, aber grundsätzlich macht er das, was Du versuchst umzusetzen.

Wenn fragen dazu sind, bezüglich einer Anpassung an Deine Datei, kommr hier rüber mit Beispieldatei:

https://www.ms-office-forum.net/forum/index.php?referrerid=81823

Option Explicit
    Dim fso As Scripting.FileSystemObject
    Dim wkbQuelle As Workbook
    Dim wksQuelle As Worksheet
    Dim wksZiel As Worksheet
    Dim m_sFolder As String
Const m_sPath As String = "ZU_DURCHSUCHENDER_PFAD"

Sub main()
    '
    Set wksZiel = ThisWorkbook.Worksheets(1)
    '
    Call ImportEachFile(m_sPath)
End Sub

Sub ImportEachFile(m_sFolder As String)
    Dim oFolder As Scripting.Folder
    Dim oFile As Scripting.File
    Dim oSubFolder As Scripting.Folder
    '
    Set fso = New Scripting.FileSystemObject
    For Each oSubFolder In fso.GetFolder(m_sFolder).SubFolders
        'go recursive
        Call ImportEachFile(oSubFolder.Name)
    Next
    '
    For Each oFile In fso.GetFolder(m_sFolder).Files
        'If Len(oFile.Name) = 11 Then
            'Open File and Import Currentregion + workdate
            Call FillOutMasterWorksheet(oFile.Path)
        'End If
    Next
End Sub


Function getCopyCurrentRegion(wks As Worksheet) As Variant
    'Dim wks As Worksheet
    Dim arr()
    Dim y As Long, x As Long
    '
    arr = wks.Range("A1").CurrentRegion
    'ReDim Preserve arr(1 To UBound(arr, 1), 1 To UBound(arr, 2) + 1)
    'For y = 1 To UBound(arr, 1) Step 1
    '    arr(y, UBound(arr, 2)) = Mid(wks.Name, 1, 2) & "." & Mid(wks.Name, 3, 2) & "." & Mid(wks.Name, 5, 2)
    'Next y
    '
    getCopyCurrentRegion = arr
End Function

Sub FillOutMasterWorksheet(sWorkbook As String)
    Dim arr() As Variant
    '
    Set wkbQuelle = Workbooks.Open(sWorkbook, False)
    With wkbQuelle
        Set wksQuelle = .Worksheets(1)
        arr = getCopyCurrentRegion(wksQuelle)
        .Close True
    End With
    '
    With wksZiel
        .Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0).Resize(UBound(arr, 1), UBound(arr, 2)).Value = arr
    End With
    '
    Erase arr
    Set wksQuelle = Nothing
    Set wkbQuelle = Nothing
End Sub