|
geht's damit ?
Dim lst As New Collection
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
|