AW: Unterverzeichnisse mit def. Anf.Buchst. durchsuche
20.07.2010 16:08:02
IngGi
Hallo Jörg,
hier eine Lösungsmöglichkeit mit dem FileSystemObject, bei der fast der gesamte Code für jeden relevanten Unterordner immer wieder neu abgearbeitet werden muss. Dazu wird dieser Codeteil in eine eigene Prozedur ausgelagert, die zunächst von der Hauptprozedur aus aufgerufen wird, nachdem dort die wenigen nicht zu wiederholenden Programmschritte gemacht worden sind.
Anschließend ruft sich die zweite Prozedur für jeden relevanten Unterordner immer wieder selbst (rekursiv) auf:
Sub Dateien_suchen()
Dim objFSO As Object
Dim objFolder As Object
Dim strFileBeg As String
Set objFSO = CreateObject("Scripting.FileSystemObject")
strFileBeg = InputBox("Bitte den Dateinamensanfang eingeben: ")
Set objFolder = objFSO.GetFolder("C:\Temp")
'Der Codeteil, der für alle relevanten Unterordner immer wieder
'abgearbeitet werden muss wurde in eine eigene Prozedur ausgelagert
'Diese Prozedur wird hier aufgerufen.
Rekursiv objFolder, strFileBeg
Set objFolder = Nothing
Set objFSO = Nothing
End Sub
Sub Rekursiv(objFolder As Object, strFileBeg As String)
Dim objFile As Object
Dim objSubFolder As Object
Dim rng As Range
'Folgende If-Bedingung verhindert, dass der Startordner
'in die Suche mit einbezogen wird
If UCase(objFolder.Path) "C:\DATA" Then
'Alle Dateien im Ordner abklappern
For Each objFile In objFolder.Files
'Wenn der Anfang des Dateinamens mit dem gesuchten Anfang übereinstimmt ...
If UCase(Left(objFile.Name, Len(strFileBeg))) = UCase(strFileBeg) Then
MsgBox objFile.Path
'Statt der Ausgabe über eine Messagebox kommt hier natürlich dein Code
'für das, was du mit den gefundenen Dateien machen willst.
'Über "Workbooks.Open(objFile.Path)" lässt sich die Datei z.B. öffnen.
End If
Next 'objFile
End If
'Alle Unterordner im Ordner abklappern
For Each objSubFolder In objFolder.SubFolders
'Wenn der Anfang des Unterordners mit dem gesuchten Anfang übereinstimmt ...
If UCase(Left(objSubFolder.Name, Len(strFileBeg))) = UCase(strFileBeg) Then
'Unterordner als neuen Ordner übernehmen
Set objFolder = objSubFolder
'Die Prozedur ruft sich für alle Unterordner immer wieder selbst auf
Rekursiv objFolder, strDatNam
End If
Next 'objSubFolder
Set rng = Nothing
Set objFile = Nothing
Set objSubFolder = Nothing
End Sub
Gruß Ingolf