Hallo zusammen,
letzte Woche habe ich ein kleines Tool gebastelt welches die Ordner in einem Verzeichnis ausliest und Zählt.
Der zu durchsuchende Pfad wird manuell eingegeben und mit einem \ abgeschlossen.
Danach muss nur noch auf Ausführen geklickt werden und die Ordner werden auf der Linken Seite aufgelistet.
Wird der Pfad nun geändert und das Tool neu ausgeführt, so listen sich die weiteren Ordner darunter.
Da das Tool für meine Kollegen gestaltet ist und nach Möglichkeit ohne mein zutun Funktionieren sollte, würde ich gerne folgende Änderung vornehmen. Anstatt den zu durchsuchenden Pfad manuell einzutippen, müsste es doch möglich sein über ein Fenster/Explorer den Pfad zu wählen (ähnlich wie bei der Auswahl eines Installationspfades für ein neuen Programm). Bisher konnte ich hierzu keinen Ansatz entdecken und hoffe daher auf die schlauen Leute hier...
Gruß
Tele
Hi,
Ordnerauswahl hatte ich erst vor kurzem
http://www.clever-excel-forum.de/thread-5762.html
ich verwende gerne Variante1
Nur bist du Dir sicher das der Code alle Ordner auflistet!?
Ich habe gerade mal einen gewählt mit > 1000 Ordnern und 70 werden angezeigt.
Warum heißt die Datei Dateien zählen und Ordner sollen aufgelistet werden :)
Code:
Sub M_snb()
with application.filedialog(4)
if .show then
sn=split(createobject("wscript.shell").exec("cmd /c dir """ & .selecteditems(1) & "\*.*"" /b").stdout.readall,vbcrlf)
cells(1,6).resize(Ubound(sn))=application.transpose(sn)
end if
end with
end sub
Klasse,
danke dafür.
Die bisherigen Ergebnisse haben alle gestimmt?!
Probeläufe waren vor allem Pfade mit größeren Mengen an Ordnern (z.b. 8800 Ordner oder 600 Ordner) und hat dort keine ausgelassen! Hast du einen Anhaltspunkt, warum es bei dir nicht geklappt hat?
Den Namen ist natürlich Blödsinn :19:
Gruß
Tele
Hi,
versuche mal das und vergleiche. (Ich gebe aber hier den ganzen Pfad aus)
Code:
Option Explicit
Dim fs As Object, First As Integer
Sub alternative_zu_application_filesearch()
'by Kaiser 2012
Dim objShell As Object
Dim BrowseDir 'mit Absicht Varianten
Dim strVerzeichnis As String
Set objShell = CreateObject("Shell.Application") 'das könnte dann weg
Set BrowseDir = objShell.BrowseForFolder(0, "Ordner auswählen", &H1000, 17) 'das könnte dann weg
'On Error Resume Next
strVerzeichnis = BrowseDir.Items().Item().Path 'oder einfach fix den Pfad eintragen ;
If strVerzeichnis = "" Then: On Error GoTo 0: Exit Sub
Set fs = CreateObject("Scripting.FileSystemObject")
First = 1
ffile strVerzeichnis
End Sub
Sub ffile(strVerzeichnis As String)
Dim MyFolder As Object, FSO As Object, StrName As String, IntC As Integer, strPath As String
Static za As Long
Set FSO = fs.GetFolder(strVerzeichnis)
For Each MyFolder In FSO.SubFolders
For IntC = 0 To First
If First = 1 Then
strPath = strVerzeichnis
First = 0
Else
strPath = MyFolder
End If
za = za + 1
Cells(za, 1).Value = strPath
Next
If FSO.SubFolders.Count > 0 Then
ffile strVerzeichnis & "\" & MyFolder.Name
End If
Next
End Sub
über Rekursion gelöst.
Das dauert aber ewig, wenn ein Verzeichnis mit tsd. von Ordnern gewählt wird.
Ansonsten gibt es noch eine Klasse von Nepumuk (über Google leicht zu finden,
https://www.google.at/?gws_rd=ssl#q=Nepu...lternative)
edit
[anbei noch etwas schneller]
bei za. 800 Ordnern inkl Unterordnen von der
Festplatte in 1 sek.
Code:
Option Explicit
Dim fs As Object, First As Integer, tmpstr As String
Sub alternative_zu_application_filesearch()
'by Kaiser 2012
tmpstr = ""
Columns(1).Clear
Dim objShell As Object, myarr
Dim BrowseDir 'mit Absicht Varianten
Dim strVerzeichnis As String
Set objShell = CreateObject("Shell.Application") 'das könnte dann weg
Set BrowseDir = objShell.BrowseForFolder(0, "Ordner auswählen", &H1000, 17) 'das könnte dann weg
'On Error Resume Next
strVerzeichnis = BrowseDir.Items().Item().Path 'oder einfach fix den Pfad eintragen ;
If strVerzeichnis = "" Then: On Error GoTo 0: Exit Sub
Set fs = CreateObject("Scripting.FileSystemObject")
First = 1
ffile strVerzeichnis
myarr = Split(tmpstr, ";")
Cells(1, 1).Resize(UBound(myarr)) = WorksheetFunction.Transpose(myarr)
End Sub
Sub ffile(strVerzeichnis As String)
Dim MyFolder As Object, FSO As Object, StrName As String, IntC As Integer, strPath As String
Set FSO = fs.GetFolder(strVerzeichnis)
For Each MyFolder In FSO.SubFolders
For IntC = 0 To First
If First = 1 Then
strPath = strVerzeichnis
First = 0
Else
strPath = MyFolder
End If
tmpstr = tmpstr & strPath & ";"
Next
If FSO.SubFolders.Count > 0 Then
ffile strVerzeichnis & "\" & MyFolder.Name
End If
Next
End Sub
übers Netzwerk mit 2500 Ordnern hat das aber mal 5 Min gedauert....
Hallo zusammen,
dank eurer Hilfe hab ich nun den gewünschten Effekt erzielt,
bin jedoch nicht sicher warum das ganze bei dir chris-ka nicht funktioniert.
Habe das ganze Lokal und auf Server Ebene mit meinem und deinem Code getestet, komme jedoch an keiner Stelle Abweichungen/fehlende Ordner feststellen.
Name ist auch angepasst :19:
Gruß
Tele
Hi,
bei mir werden nach wie vor keine Unterordner angezeigt :)
lg
Hallöchen,
der tele..-Code geht nicht rekursiv weiter nach unten. Es werden nur die Unterordner des gewählten Ordners angezeigt, nicht jedoch die Unterordner der Unterordner usw.
Guten Morgen zusammen,
der Code soll ja auch nicht die Unterordner auflisten, also alles in Ordnung!
Vielen Dank zusammen und ein schönes Wochenende...
Gruß
Tele