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