Option Explicit

' Dieser Source stammt von http://www.activevb.de
' und kann frei verwendet werden. Für eventuelle Schäden
' wird nicht gehaftet.
' Der VB Code ist aus dem Beitrag http://www.activevb.de/tipps/vb6tipps/tipp0492.html
' Verweis: Microsoft Scripting Runtime
' Originalcode
'Dim i As Long
'With Application.FileSearch
'    .NewSearch
'    .LookIn = ActiveWorkbook.Path   'Suchverzeichnis
'    .SearchSubFolders = False       'True wäre mit Unterverzeichnissen
'    .Filename = "*.csv"             'Dateien die mit .csv änden
'    .Execute                        'suche ausführen
'    For i = 1 To .FoundFiles.Count
'        Application.StatusBar = "-->>   Einlesen der Datei:  " & i & " / " & .FoundFiles.Count & "  <<--"
'        Call importieren_und_verschieben(.FoundFiles(i))
'    Next i
'End With
'
Dim LoJ As Long                                     ' Variable für Zeile

Sub Start()
    ' alles Löschen außer Zeile 1
    Application.ScreenUpdating = False
    If ActiveSheet.UsedRange.SpecialCells(xlCellTypeLastCell).Row > 1 Then
        Rows("2:" & ActiveSheet.UsedRange.SpecialCells(xlCellTypeLastCell).Row).Delete
    End If
    LoJ = 2
    SearchInFolder ThisWorkbook.Path
    Application.ScreenUpdating = True
End Sub

Private Sub SearchInFolder(ByVal Folderspec As String)  ' auslesen aufrufen mit Ordnername
    Dim StTyp As String                                 ' Dateityp
    Dim FSO As New FileSystemObject
    Dim SearchFolder As Folder
    Dim FD As Folder, FI As File
    Dim EachFil As Files, EachFold As Folders
    Dim LoI As Long                                     ' Laufvariable zum schreiben der Ordner
    Dim Loletzte As Long                                ' Variable für letzte Zeile
    Dim InSpalte As Integer                             ' Variable für Spalte
    StTyp = "xlsx"
    Set SearchFolder = FSO.GetFolder(Folderspec)
    Set EachFil = SearchFolder.Files            ' Dateien in der jeweiligen Root
'   Dateien auslesen
    For Each FI In EachFil                      ' Schleife über alle Dateien
'       Dateityp feststellen
        If UCase(Right(FI.Name, Len(FI.Name) - InStrRev(FI.Name, "."))) = UCase(StTyp) Then
            If UCase(Right(FI.Name, 4)) = "XLSX" Then
                Workbooks.Open ThisWorkbook.Path & "\" & FI.Name
                Loletzte = ActiveSheet.UsedRange.SpecialCells(xlCellTypeLastCell).Row
                InSpalte = ActiveSheet.UsedRange.SpecialCells(xlCellTypeLastCell).Column
                Range(Range("A1"), Cells(Loletzte, InSpalte)).Copy ThisWorkbook.Worksheets(1).Cells(LoJ, 2)
                With ThisWorkbook.Worksheets(1)
                    .Range(.Cells(LoJ, 1), .Cells(LoJ + Loletzte - 1, 1)) = ActiveWorkbook.Name
                End With
                LoJ = LoJ + Loletzte
                ActiveWorkbook.Close False
            End If
        End If
    Next FI
    Set EachFil = Nothing
    Set EachFold = Nothing
    Set FSO = Nothing
End Sub