Ordner anzeigen und filtern

Sub Ordner_laden() Worksheets("Ablage").Range("A3:C300").ClearContents Worksheets("Ablage").Range("A3").Select Const Verz = "O:\Kundenneuanlagen\Kundenneuanlagen 2011\" Dim Ordner Dim Var Dim FSO As Object Set FSO = CreateObject("Scripting.filesystemobject") For Each Ordner In FSO.getfolder(Verz).subfolders With ActiveCell .Value = Ordner 'schreib den Pfad in Spalte A .Offset(0, 1).Value = Ordner.Name 'schreibt nur den Namen in Spalte B. Offset(1, 0).Select End With Next Worksheets("Ablage").Range("A3").Select End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Benutzer

Sub Ordner_laden() Worksheets("Ablage").Range("A3:C300").ClearContents Worksheets("Ablage").Range("A3").Select Const Verz = "O:\Kundenneuanlagen\Kundenneuanlagen 2011\" Dim Ordner Dim MyArr0() As Variant, MyArr1() As Variant, i As Long Dim FSO As Object Set FSO = CreateObject("Scripting.filesystemobject") ReDim MyArr0(0) ReDim MyArr1(0) i = 1 For Each Ordner In FSO.getfolder(Verz).subfolders ReDim Preserve MyArr0(i) ReDim Preserve MyArr1(i) MyArr0(i) = Ordner MyArr1(i) = Ordner.Name i = i + 1 Next 'schreibe array in tabelle With ThisWorkbook.Sheets("Ablage") .Range(Cells(3, 1), Cells(UBound(MyArr0) + 2, 1)) = Application.Transpose(MyArr0) .Range(Cells(3, 2), Cells(UBound(MyArr1) + 2, 2)) = Application.Transpose(MyArr1) End With Worksheets("Ablage").Range("A3").Select End Sub

Hallo Dirk,
danke für deinen Lösungsvorschlag.
Deine Idee ist wohl eine etwas sauberere Lösung wie man die Daten ins Tabellenblatt überträgt.
Aber ich glaub der eigentliche Rechenaufwand liegt darin das er jeden Ordner durchgehen muss.
Ich hab mal die Zeit bei beiden gestoppt ^^ der erste Code dauerte 40,9 Sekunden deiner 37,0.
Vielleicht kann man irgendwie gleich nur bestimmte Ordner ansprechen.
In dem Verzeichnis gibt es Ordner mit Nummern und Buchstaben z.B. 225654654 A ABC
und Ordner nur mit Buchstaben z.B. A ABC.
Ich benötige eine Liste von den Ordnern ohne Nummer. (Filter ich bis jetzt im Nachhinein aus)
Ich hab es wie gesagt schon mit einer IF Formel in der FOR EACH probiert,
dass hat funktioniert aber war nicht schneller als vorher.
Außerdem hab ich es leider nur sehr umständlich geschafft die mit Zahlen anfangenden auszufiltern (siehe Code):
For Each Ordner In FSO.getfolder(Verz).subfolders
If Not Ordner.Name Like "1*" Then
If Not Ordner.Name Like "2*" Then
If Not Ordner.Name Like "3*" Then
If Not Ordner.Name Like "4*" Then
If Not Ordner.Name Like "5*" Then
If Not Ordner.Name Like "6*" Then
If Not Ordner.Name Like "7*" Then
If Not Ordner.Name Like "8*" Then
If Not Ordner.Name Like "9*" Then
With ActiveCell
.Value = Ordner
.Offset(0, 1).Value = Ordner.Name
.Offset(1, 0).Select
End With
End If
End If
End If
End If
End If
End If
End If
End If
End If
Next
Mfg
Borat

Sub Ordner_laden() Worksheets("Ablage").Range("A3:C300").ClearContents Worksheets("Ablage").Range("A3").Select Const Verz = "O:\Kundenneuanlagen\Kundenneuanlagen 2011\" Dim Ordner Dim MyArr0() As Variant, MyArr1() As Variant, i As Long Dim FSO As Object Set FSO = CreateObject("Scripting.filesystemobject") ReDim MyArr0(0) ReDim MyArr1(0) i = 1 For Each Ordner In FSO.getfolder(Verz).subfolders if not isnumeric(left(ordner.name,1)) then ReDim Preserve MyArr0(i) ReDim Preserve MyArr1(i) MyArr0(i) = Ordner MyArr1(i) = Ordner.Name i = i + 1 end if Next 'schreibe array in tabelle With ThisWorkbook.Sheets("Ablage") .Range(Cells(3, 1), Cells(UBound(MyArr0) + 2, 1)) = Application.Transpose(MyArr0) .Range(Cells(3, 2), Cells(UBound(MyArr1) + 2, 2)) = Application.Transpose(MyArr1) End With Worksheets("Ablage").Range("A3").Select End Sub

Beliebteste Forumthreads (12 Monate)

4 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

4
Beiträge zum Forumthread

Beiträge zu diesem Forumthread