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
