Hallo Brumms,
Ich habe mal deine Funktion ausprobiert:
Sub FileSearch()
Dim sStartPath As String
Dim sWhat As String
Dim result As String
Dim t As Integer
Dim tmp As String
sStartPath = "C:\book\" 'Where?
sWhat = "*.xls" 'What?
If lst.Count > 0 Then
Do
lst.Remove lst.Count 'clears list if data already exists
Loop Until lst.Count = 0
End If
ThisWorkbook.Sheets(1).Columns(1).ClearContents
result = DigIn2(sStartPath, sWhat) 'First step
For t = lst.Count To 1 Step -1
ThisWorkbook.Sheets(1).Cells(t, 1) = lst(t) 'puts data in 1st sheet, 1st column
lst.Remove t
Next t
Columns("A:A").Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlNo, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
End Sub
Function DigIn2(sPath As String, sWhat As String)
Dim fs
Dim dDirs
Dim dDir
Dim fFile
Dim c As Variant
Dim tmp As String
Set fs = CreateObject("Scripting.FileSystemObject")
Set dDirs = fs.GetFolder(sPath)
For Each dDir In dDirs.SubFolders
tmp = DigIn2(dDir.Path, sWhat)
Next
tmp = Dir(dDirs.Path & "\" & sWhat)
If tmp <> "" Then
Do
lst.Add dDirs.Path & "\" & tmp
tmp = Dir
Loop Until tmp = ""
Exit Function
End If
End Function
Sollte in Excel 2002 - 2010 funktionieren, verwendet die gleichen Objekte die ich bisher verwendet habe, ist sogar deutlich schneller als das was ich bisher benutzt habe (man kann so aber keine .temp files auflisten, oder?).
Hab das Ganze noch ein bisschen optimiert:
Function startListFiles( _
List$(), ByVal Path$, _
Optional ByVal Subfolders As Boolean = False, _
Optional ByVal FilenameFilter$ = "*", _
Optional ByVal ExtensionFilter$ = "*" _
) As Boolean
'check for errors
If FolderDoesntExist(Path) Then
startListFiles = "Folder doesn't exist"
Exit Function
End If
'start search
startListFiles = ListFiles(List, Path, Subfolders, FilenameFilter, ExtensionFilter)
End Function
Private Function ListFiles(List$(), ByVal Path$, ByVal Subfolders As Boolean, ByVal FilenameFilter$, ByVal ExtensionFilter$, _
Optional ByRef a& = -1) As Boolean
Dim oFS As Object, OFolder As Object, oSubfolder As Object, OFile As Object
Dim E&, b&, tmp$
'set
Set oFS = CreateObject("Scripting.FileSystemObject")
Set OFolder = oFS.GetFolder(Path)
'search
'subfolders
On Error Resume Next
If Subfolders Then
For Each oSubfolder In OFolder.Subfolders
ListFiles List, oSubfolder.Path, Subfolders, FilenameFilter, ExtensionFilter, a
Next
End If
On Error GoTo 0
'folder
E = OFolder.FILES.Count
If E = 0 Then Exit Function
ReDim Preserve List(a + E)
tmp = Dir(Path & "\" & FilenameFilter & "*" & ExtensionFilter)
While tmp <> ""
a = a + 1
List(a) = Path & "\" & tmp
tmp = Dir
Wend
If a >= 0 Then ReDim Preserve List(a)
ListFiles = True
'reset
Set OFolder = Nothing
Set oFS = Nothing
Set oSubfolder = Nothing
Set OFile = Nothing
End Function
Läuft bei größeren Datenmengen sehr viel schneller (ohne die Übertragung in Excel zu berücksichtigen).
Irgendwelche Verbesserungsvorschläge? Kennst du eine Funktion die unter VBA schneller läuft?
Gruß
Till
|