VBA nur die ersten Unterordner anzeigen lassen?
Hallo,
wie muss ich diesen Code hier umschreiben damit NICHT die Unterordner der Unterordner angezeigt werden, sondern nur die der 'ersten Stufe'.
Also angenommen auf dem Laufwerk C:\ sind die Ordner
A, B, C, D, E
und diese Unterordner von C:\ enthalten jeweils auch Unterordner Namens
aa, bb, cc, dd, ee,
Dann schreibt der bisherige Code
A - aa
bb
cc
dd
ee
B - aa
bb
und so weiter.
Ich brauche aber nur die Ordner A, B, C, D, E und nicht deren Unterordner.
Public Sub OrdnerListen_Start()
Dim fso As Object
Dim strPfad As String
strPfad = "C:\"
With ActiveSheet
.UsedRange.ClearContents
Set fso = CreateObject("Scripting.FileSystemObject")
Call OrdnerListen(fso, strPfad, .Range("A1")) ' Pfad anpassen!
Set fso = Nothing
End With
End Sub
Private Sub OrdnerListen(fso As Object, Ordnerangabe As String, rng As Range, Optional Zeile As Long, Optional Spalte As Long)
On Error Resume Next
Dim o, uo
Set o = fso.GetFolder(Ordnerangabe)
rng.Offset(Zeile, Spalte).Value = o.Name
Zeile = Zeile + 1
For Each o In o.SubFolders
Call OrdnerListen(fso, o.Path, rng, Zeile, Spalte)
Next
Set o = Nothing
Set uo = Nothing
End Sub
3 Antworten
Du rufst den Code ja auch immer wieder selbst auf, dann hacckt der natürlich alle durch.
Probier mal das
Public fso As Object
Public Sub OrdnerListen_Start()
Dim strPfad As String
strPfad = "C:\"
Set fso = CreateObject("Scripting.FileSystemObject")
With ActiveSheet
.UsedRange.ClearContents
Call OrdnerListen(fso, strPfad, .Range("A1")) ' Pfad anpassen!
End With
End Sub
Private Sub OrdnerListen(fso As Object, Ordnerangabe As String, rng As Range, Optional Zeile As Long, Optional Spalte As Long)
On Error Resume Next
Dim o, uo
Set o = fso.GetFolder(Ordnerangabe)
rng.Offset(Zeile, Spalte).Value = Ordnerangabe 'Ausgewälter Pfad
Zeile = Zeile + 1
For Each uo In o.SubFolders
rng.Offset(Zeile, Spalte + 1).Value = uo.Name
Zeile = Zeile + 1
Next
Set o = Nothing
Set uo = Nothing
End Sub
Man kann auch klassisch mit der "DIR" Auflistung arbeiten und so das FSO Objekt sparen, sofern man nur die Erste Ebene will.
Geh unter Extras/Verweise/Microsoft Scripting Runtime anhackeln.
Const Zielpath As String = "C:\"
Sub Main()
OrdnerListen_Start
End Sub
Private Sub OrdnerListen_Start()
Dim FSO As FileSystemObject
Set FSO = CreateObject("Scripting.FileSystemObject")
Dim strPfad As String
strPfad = Zielpath
With ActiveSheet
.UsedRange.ClearContents
Call OrdnerListen(FSO, strPfad, .Range("A1")) ' Pfad anpassen!
Set FSO = Nothing
End With
End Sub
Private Sub OrdnerListen(FSO As FileSystemObject, Ordnerangabe As String, rng As Range, Optional Zeile As Long, Optional Spalte As Long)
On Error Resume Next
Dim uo
rng.Offset(Zeile, Spalte).Value = o.Name
Zeile = Zeile + 1
For Each o In FSO.GetFolder(Ordnerangabe).SubFolders
Call OrdnerListen(fso, o.Path, rng, Zeile, Spalte)
Next
Set o = Nothing
Set uo = Nothing
End Sub
Lg