Excel & VBA

Vorsicht: Die Laufzeit dieser Schleifen kann sehr lang sein. Es ist deshalb mehr als ratsam, die zu durchsuchenden Ordner so stark wie möglich einzugrenzen.

Erste Möglichkeit:

Dim strPfad As String, bolWeiter As Boolean 'Aufruf Sub Suchen() strPfad = "": bolWeiter = True: Dateisuche "C:\", "test.txt" Range("A1") = strPfad End Sub Function Dateisuche(strLaufwerk, strDatei) Dim strTemp As String, strWdhlg As String On Error Resume Next strLaufwerk = strLaufwerk & IIf(Right(strLaufwerk, 1) <> "\", "\", "") strTemp = Dir(strLaufwerk & strDatei) Do While Len(strTemp) strPfad = strLaufwerk & strTemp If UCase(strTemp) = UCase(strDatei) Then Dateisuche = strPfad bolWeiter = False: Exit Function End If strTemp = Dir() Loop strTemp = Dir(strLaufwerk, vbDirectory) Do While Len(strTemp) If (strTemp <> ".") And (strTemp <> "..") Then If (GetAttr(strLaufwerk & strTemp) And vbDirectory) = vbDirectory Then If bolWeiter = True Then Dateisuche strLaufwerk & strTemp, strDatei Else Exit Function strWdhlg = Dir(strLaufwerk, vbDirectory) Do While strWdhlg <> strTemp: strWdhlg = Dir(): Loop End If End If strTemp = Dir() Loop End Function

Zweite Möglichkeit:

Sub suchen1() Dim fso As Object Set fso = CreateObject("Scripting.FileSystemObject") Dateisuche fso.GetFolder("C:"), "test.txt" Set fso = Nothing End Sub Sub Dateisuche(objErstOrdner As Object, strDatei As String) Dim objDatei As Object, objOrdner As Object, sf As Object For Each objDatei In objErstOrdner.Files If LCase(objDatei.Name) = strDatei Then MsgBox objDatei.Path End If Next For Each objOrdner In objErstOrdner.SubFolders Dateisuche objOrdner, strDatei Next End Sub

Es wird geprüft, ob der Ordner existiert. Wenn nicht, wird er erstellt. Ggf. noch daran denken, etwaige Fehler abzufangen.

Dim strPfad As String strPfad = "\\COMPUTER\Ordner\Unterordner\" 'Beispiel für Netzwerk strPfad = "C:\Temp\" 'Beispiel lokal If Dir(strPfad, vbDirectory) <> "" Then MsgBox "Verzeichnis existiert bereits" Else MkDir strPfad End If

An der Stelle des Sternchens in Dir(strOrdner & "*.*") können auch bestimmte Dateiendungen eingetragen wreden, so dass nur nach Dateien eines Typs gesucht wird.

Subs

Sollen Dateien nur direkt im Ordner, nicht aber in Unterordnern, gesucht werden, reicht dieser Code:

Sub Suchen_nur_Dateien() Dim strOrdner As String, strDatei As String Dim lngZ As LongPtr strOrdner = "C:\Eigene Dateien\" lngZ = 2 Range("a1:e50000").ClearContents strDatei = Dir(strOrdner & "*.*") Do While strDatei <> "" If strDatei <> "" Then lngZ = lngZ + 1 Cells(lngZ, 1) = strOrdner & strDatei 'Pfad Cells(lngZ, 2) = FileLen(strOrdner & strDatei) 'Grö�e Cells(lngZ, 3) = FileDateTime(strOrdner & strDatei) 'Datum/Zeit Cells(lngZ, 4) = strDatei 'nur Dateiname End If strDatei = Dir Loop End Sub

Soll auch in Unterordnern gesucht werden, ist dies eine Möglichkeit:

Private lngZ As LongPtr Sub Suchen_mit_Unterordnern() 'Aufruf lngZ = 2 Range("a1:e50000").ClearContents Dateisuche "C:\Eigene Dateien", "*.*" End Sub Sub Dateisuche(strOrdner As String, strDateien As String) Dim strTemp As String, strWdhlg As String strOrdner = strOrdner & IIf(Right(strOrdner, 1) <> "\", "\", "") strTemp = Dir(strOrdner & strDateien) Do While Len(strTemp) Cells(lngZ, 1) = strOrdner & strTemp 'Pfad Cells(lngZ, 2) = FileLen(strOrdner & strTemp) 'Grö�e Cells(lngZ, 3) = FileDateTime(strOrdner & strTemp) 'Datum/Zeit Cells(lngZ, 4) = strTemp 'nur Dateiname lngZ = lngZ + 1 strTemp = Dir() Loop strTemp = Dir(strOrdner, vbDirectory) Do While Len(strTemp) If (strTemp <> ".") And (strTemp <> "..") Then If (GetAttr(strOrdner & strTemp) And vbDirectory) = vbDirectory Then Dateisuche strOrdner & strTemp, strDateien lngZ = lngZ - 1 strWdhlg = Dir(strOrdner, vbDirectory) lngZ = lngZ + 1 Do While strWdhlg <> strTemp: strWdhlg = Dir(): Loop End If End If strTemp = Dir() Loop On Error GoTo 0 End Sub

Matrixfunktion für dynamische Arrayformel

Wenn es nicht zu viele Dateien sind, können die auch mit einer Formel, die in einer Zelle steht, ausgegeben werden (ab Excel 365). Dazu dient folgende benutzerdefinierte Funktion (UDF):

Function Suchen_nur_Dateien(strOrdner) Dim strDatei As String, arrTemp() Dim lngArr As LongPtr lngArr = 0 strDatei = Dir(strOrdner & "*.*") Do While strDatei <> "" If strDatei <> "" Then lngArr = lngArr + 1 ReDim Preserve arrTemp(1 To 4, 1 To lngArr) arrTemp(1, lngArr) = strOrdner & strDatei 'Pfad arrTemp(2, lngArr) = FileLen(strOrdner & strDatei) 'Grö�e arrTemp(3, lngArr) = FileDateTime(strOrdner & strDatei) 'Datum/Zeit arrTemp(4, lngArr) = strDatei 'nur Dateiname End If strDatei = Dir Loop Suchen_nur_Dateien = arrTemp End Function

Wenn in A1 der Ordner (z. B. C:\Eigene Dateien\) steht, kann in eine andere Zelle folgende Formel eingetragen werden:

=MTRANS(Suchen_nur_Dateien(A1))

Damit werden die gefundenen Dateien ab der Zelle mit der Formel gefloatet eingetragen (verschüttet). Auch die Suche mit den Unterordnern lässt sich in dieser Form gestalten - aber Vorsicht, damit die Formel nicht ewig zum Berechnen braucht.