Office: Alle Unterordner eines Verzeichnisses durchsuchen

Theo76 · 18. Oktober 2017

Moin zusammen!

Ich hoffe, ihr könnt mir bei folgendem Problem helfen: ich will in meinem Programm abhängig von einer User-Abfrage von verschiedenen Start-Verzeichnissen ausgehen und in diesen Start-Verzeichnissen alle Dateien in allen Unterordnern durchsuchen und sie bearbeiten. Gleichzeitig müssen auch die Dateien gezählt werden (dies wird für die Berechnung eines Mittelwerts gebraucht).
In meinem Programm besteht jetzt das Problem, dass nur die erste Ebene an Unterordnern durchsucht wird, aber nicht die "Unter-Unterordner". Die reale Ordnerstruktur kann so aussehen (Datei- und Ordnernamen sind nicht die realen Namen):

"...Gesamt/Einzel/KB/F-1/P-1/Datei_P1_1...P1_n.xlx"
"...Gesamt/Einzel/KB/F-1/P-2/Datei_P2_1...P2_n.xlx"

Gesamt ist mein Hauptordner, darunter liegen mehrere Einzel-Ordner und in jedem Einzelordner nochmal diverse andere Ordner.
Der Nutzer soll dabei beispielsweise Gesamt oder Einzel oder KB oder F-1 oder P-1 oder P-2 als Startverzeichnis auswählen können, um jeweils eine größere oder kleinere Anzahl an Dateien zu benutzen. (Die Auswahl über die UserForm habe ich im Code bewusst gekürzt dargestellt.)

Hier der Code:

Code:

'function to store the relevant data in different arrays
Private Function GetData()

Dim n As Integer
Dim iter1 As Integer
Dim iter2 As Integer
Dim iter3 As Integer
Dim iter4 As Integer
Dim iter5 As Integer

Dim wb As Workbook
Dim myPath As String

Dim objFSO As Object
Dim objFolder As Object
Dim objSubFolder As Object
Dim objSubSubFolder As Object
Dim objFile As Object

Application.ScreenUpdating = False

'set filepaths due to checkboxes from UserForm1
'If checkboxVal(1) = True Then
myPath = "P:/.../KB/" 'Schrägstrich bewusst umgedreht, da die anderen hier im Forum wohl nicht angezeigt werden können
'End If

'set counted files to zero
countedFiles = 0

'set FileSystemObject and path
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder(myPath)

'loop through all Subfolders in selected folder path
For Each objSubFolder In objFolder.SubFolders 'HIER WIRD NUR 1 EBENE AN UNTERORDNERN DURCHSUCHT (NICHT: ORDNER - UNTERORDNER - UNTERORDNER)
For Each objFile In objSubFolder.Files
Set wb = Workbooks.Open(objFile)

'choose Worksheet "Selbsteinschätzungsbogen" and get all values from each theme
With wb.Worksheets("Selbsteinschätzungsbogen")

Application.ScreenUpdating = False
For iter1 = 0 To 7
valArray1(iter1) = valArray1(iter1) + .Cells(16 + (iter1 * 7), 16).Value 'Themenfeld 1 ab Zeile 16
Next iter1

For iter2 = 0 To 5
valArray2(iter2) = valArray2(iter2) + .Cells(73 + (iter2 * 7), 16).Value 'Themenfeld 2 ab Zeile 73
Next iter2

For iter3 = 0 To 6
valArray3(iter3) = valArray3(iter3) + .Cells(116 + (iter3 * 7), 16).Value 'Themenfeld 3 ab Zeile 116
Next iter3

For iter4 = 0 To 3
valArray4(iter4) = valArray4(iter4) + .Cells(166 + (iter4 * 7), 16).Value 'Themenfeld 4 ab Zeile 166
Next iter4

For iter5 = 0 To 3
valArray5(iter5) = valArray5(iter5) + .Cells(195 + (iter5 * 7), 16).Value 'Themenfeld 5 ab Zeile 195
Next iter5

End With
'after getting all values the workbook has to be closed
'addition: "wb.Saved = True" in order to prevent Save Dialog to be opened everytime
wb.Saved = True
wb.Close

'count files for computing arithmetic average
countedFiles = countedFiles + 1
Next objFile
Next objSubFolder

MsgBox ("Der Pfad ist: " & myPath) 'Zum Testen
MsgBox ("Anzahl der Files: " & countedFiles) 'Zum Testen

End Function
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Meine Frage: Gibt es eine Möglichkeit, alle Ebenen des Start-Verzeichnisses zu durchsuchen und wenn ja, wie könnte diese aussehen?

Vielen Dank und viele Grüße,
Theo

:)

Fennek11 · 19. Oktober 2017

Hallo,

ja,es gibt eine "einfache" Variante. Diese bassiert auf dem alten DOS-Befehl

PHP:

dir /s *.xlsx > c:tempMeineListe.txt

Storax · 20. Oktober 2017

Code:

Sub GetFiles(StartFolder As String, Pattern As String, _
DoSubfolders As Boolean, ByRef colFiles As Collection)

Dim f As String, sf As String, subF As New Collection, s

If Right(StartFolder, 1) "" Then StartFolder = StartFolder & ""

f = Dir(StartFolder & Pattern)
Do While Len(f) > 0
colFiles.Add StartFolder & f
f = Dir()
Loop

sf = Dir(StartFolder, vbDirectory)
Do While Len(sf) > 0
If sf "." And sf ".." Then
If (GetAttr(StartFolder & sf) And vbDirectory) 0 Then
subF.Add StartFolder & sf
End If
End If
sf = Dir()
Loop

For Each s In subF
GetFiles CStr(s), Pattern, True, colFiles
Next s

End Sub
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Theo76 · 20. Oktober 2017

Hallo ihr beiden,

Vielen Dank für die Lösungsmöglichkeiten!!

Ich habe in der Zwischenzeit eine andere Lösung gefunden und diese bei mir eingebaut.
Falls jemanden diese weitere Lösung interessiert: http://www.xl-central.com/list-the-f...ubfolders.html.

Was mich noch interessieren würde: Geht der Weg über DIR schneller als das Arbeiten mit FSO?

Storax · 20. Oktober 2017

Die Lösung aus dem Link ist "lahm", weil die direkt ins Blatt schreibt und dabei nicht mal das Screenupdating abgeschaltet hat.

Hier etwas zu Deiner Frage, und hier

Aber evtl. ist das ja was für Dich

Storax · 20. Oktober 2017

PS Habe nicht daran gedacht, dass Links zum "Nachbarforum" blockiert werden, also hier neuer Versuch

Theo76 · 24. Oktober 2017

Hey, danke für die Links!

Musste mich erstmal um das "Vorgeplänkel" in der Programmierung kümmern, also die Auswahl der Pfade aus der UserForm etc.

Ich werde mal überprüfen, wie ich mein Programm von FSO auf die Nutzung der DIR-Funktion umschreiben kann.

Ich meld mich dann nochmal. *Smilie

Office: Alle Unterordner eines Verzeichnisses durchsuchen

Alle Unterordner eines Verzeichnisses durchsuchen

Alle Unterordner eines Verzeichnisses durchsuchen

Alle Unterordner eines Verzeichnisses durchsuchen

Alle Unterordner eines Verzeichnisses durchsuchen - Similar Threads - Unterordner Verzeichnisses durchsuchen

Schriftgröße in Email Unterordner ändern...

Outlook Emails inkl. aller Unterordner pro Tag zählen/auswerten

VBA Unterordner

Ordner mit Unterordner per VBA erstellen

Posteingang Unterordner entfernen

auch Unterordner berücksichtigen

MS Teams / SharePoint übergeordnete Ordner lassen sich nicht löschen, wenn Unterordner oder ...