Option Explicit

Const strPath = "C:\Eigene Dateien\"

Sub Dateien_auslesen()
Dim Datei$
Dim lngFirstRow As Long
Dim lngLastRow As Long
Dim intDaten As Integer

Application.ScreenUpdating = False

Datei = Dir(strPath & "*.xls")
Do While Datei <> ""
    If Right(Datei, 4) = ".xls" Then
        Workbooks.Open strPath & Datei
        For intDaten = 1 To 37 Step 6
            lngFirstRow = ThisWorkbook.Sheets(1).Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
            lngLastRow = Workbooks(Datei).Sheets(1).Cells(65536, intDaten).End(xlUp).Row
            Workbooks(Datei).Sheets("Tabelle1").Range(Cells(2, intDaten), Cells(lngLastRow, intDaten + 6)).Copy
                ThisWorkbook.Sheets(1).Cells(lngFirstRow, 1).PasteSpecial
        Next
        Application.DisplayAlerts = False
        Workbooks(Datei).Close
        Application.DisplayAlerts = True
    End If
    Datei = Dir()
Loop
End Sub

Option Explicit

Dim objFileSystemObject As Object
Dim objAnzDateien As Object
Dim objDurchläufe As Object
Dim objDateityp As Object
Dim lngrow As Long

Const strPath = "C:\Eigene Dateien\"

Sub Prüfung_start()
Set objFileSystemObject = CreateObject("Scripting.FileSystemObject")
Set objAnzDateien = objFileSystemObject.getfolder(strPath)
Call Prüfung
End Sub


Sub Prüfung()

For Each objDateityp In objAnzDateien.Files
    If Right(objDateityp.Name, 4) = ".xls" And objDateityp.Name <> ThisWorkbook.Name _
      And IsNumeric(Left(Datei, 2)) Then
        lngrow = ActiveSheet.Cells(Rows.Count, 3).End(xlUp).Offset(1, 0).Row

        GetObject (objDateityp)
        With Workbooks(objDateityp.Name)
            .Sheets(1).Range("A1:H200").Copy
            ActiveSheet.Cells(lngrow, 3).PasteSpecial Paste:=xlPasteValues
            .Close
        End With
    End If
Next

For Each objDurchläufe In objAnzDateien.subfolders
   Set objAnzDateien = objDurchläufe
   Call Prüfung
Next

Set objFileSystemObject = Nothing
Set objAnzDateien = Nothing

End Sub