AW: Nur Userverzeichnis oder SpecialFolder?
27.07.2017 21:15:17
Zwenn
Hallo Peter,
ich habe Dir jetzt eine Funktion gebaut, die den Verzeichnisbaum ab einem definierten Startverzeichnis rekursiv durchläuft, bis ein angegebenes Zielverzeichnis gefunden wurde. Die Fehlerbehandlungsroutine fängt Systemordner ab, für die keine Zugriffsrechte bestehen.
Du kannst in der Sub Deine benötigten Daten für Startverzeichnis, Zielverzeichnis, Tabelle in die geschrieben werden soll und Zeile ab der geschrieben werden soll einfach ändern. Das sind Variablen-, bzw. Konstantenwerte.
Die Auflistung der Dateien wird durch das Muster *.xls* gefiltert. Da musst Du mal sehen, ob dabei das rauskommt, was Du brauchst. Unter anderem werden dadurch auch .xls und .xlsb Dateien aufgelistet. Wenn Du wirklich unterschiedliche Dateierweiterungen eingeben willst, dann muss man aus der Variable ein Array machen und den Ausleseteil für die Dateien über eine Schleife für alle Endungen laufen lassen.
Das Ganze dauert je nachdem, wie tief Dein Verzeichnissbaum ab dem Startverzeichnis noch ist, unterschiedlich lange. Bei mir hat der Test ein paar Sekunden gedauert, aber ich habe natürlich einfach irgendwo in den Untiefen meiner bestehenden Verzeichnisse gesucht. Diese Untiefen sind nur nicht so richtig tief ;-)
Naja, probiers halt einfach mal aus. Den folgenden Quellcode einfach in ein Standardmodul kopieren, ggf. die oben genannten Daten anpassen und los gehts. Die Sub basiert auf dem Code von Uwe:
(Die durch die Unterstriche erzeugten Zeilenumbrüche musst Du ggf. entfernen.)
Option Explicit
Sub BestimmteDateienAusVerzeichnis()
Const zielTabellenName As String = "Tabelle1"
Dim laufwerke() As Variant
Dim laufwerk As Variant
Dim zielTabelle As Worksheet
Dim zeile As Long
Dim teilpfad As String
Dim ext As String
Dim datei As String
Dim userName As String
Dim zielVerzeichnis As String
Dim ganzerPfad As String
Dim ausgangsVerzeichnisPfad As String
zielVerzeichnis = "TestPerson"
ext = "*.xls*"
laufwerke = Array("C:", "Z:")
userName = Environ("username")
zeile = 2 'Zeile ab der die Dateien in die Ziel-Tabelle eingetragen werden
teilpfad = "\Users\" & userName & "\"
Set zielTabelle = Sheets(zielTabellenName)
For Each laufwerk In laufwerke
ausgangsVerzeichnisPfad = laufwerk & teilpfad
ganzerPfad = VerzeichnisFinden(ausgangsVerzeichnisPfad, zielVerzeichnis)
If ganzerPfad "Falscher Pfad" Then
Exit For
End If
Next laufwerk
If ganzerPfad "Falscher Pfad" Then
Cells(2, 1).Value = ganzerPfad
datei = Dir(ganzerPfad & ext)
Do While Len(datei) > 0
zielTabelle.Cells(zeile, 2) = datei
zeile = zeile + 1
datei = Dir() ' nächste Datei
Loop
Else
MsgBox "Der richtige Pfad wurde nicht gefunden."
End If
End Sub
Function VerzeichnisFinden(startVerzeichnisPfad As String, zielVerzeichnis As String) As String
Dim fso As Object
Dim startVerzeichnis As Object
Dim verzeichnis As Object
Dim fundVerzeichnisPfad As String
Dim unterVerzeichnisse As Object
On Error GoTo ErrorHandler
If Dir(startVerzeichnisPfad, vbDirectory) "" Then
Set fso = CreateObject("Scripting.FileSystemObject")
Set startVerzeichnis = fso.GetFolder(startVerzeichnisPfad)
Set unterVerzeichnisse = startVerzeichnis.SubFolders
For Each verzeichnis In unterVerzeichnisse
If verzeichnis.Name zielVerzeichnis Then
fundVerzeichnisPfad = VerzeichnisFinden(startVerzeichnisPfad & verzeichnis.Name _
& "\", zielVerzeichnis)
If Right(fundVerzeichnisPfad, Len(zielVerzeichnis) + 1) = zielVerzeichnis & "\" _
Then
Exit For
End If
Else
fundVerzeichnisPfad = startVerzeichnisPfad & verzeichnis.Name & "\"
Exit For
End If
Next
Set unterVerzeichnisse = Nothing
Set startVerzeichnis = Nothing
Set verzeichnis = Nothing
Set fso = Nothing
End If
If Right(fundVerzeichnisPfad, Len(zielVerzeichnis) + 1) = zielVerzeichnis & "\" Then
VerzeichnisFinden = fundVerzeichnisPfad
Else
VerzeichnisFinden = "Falscher Pfad"
End If
Exit Function
ErrorHandler:
If Err.Number = 52 Then
VerzeichnisFinden = "Falscher Pfad"
End If
End Function
Viele Grüße,
Zwenn