Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
1012to1016
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Dateinamen auslesen inkl. Unterordner

Dateinamen auslesen inkl. Unterordner
02.10.2008 11:32:24
Markus
Hallo,
such ein Makro das mir alle Ordner inkl. Unterordner ausliest und in Excel einfügt.
Das Makro soll am Anfang den Hauptordner über eine MsgBox auswählen lassen,
dann alle Dateinamen aus den Unterordnern in eine neue Spalte einlesen.
Spalte A = Ordner 1
Spalte B = Ordner 2
usw.
Hab schon sowas ähnliches aber das is mir zu unflexsibel in der Ordnerauswahl (Ordner sind fest vordefiniert)
strOrdner = Array("Z:\Hauptansicht\", "Z:\Seitenansicht\", "Z:\Unten\")
Wie gesagt möchte den Ordner auswählen können und dann die unterordner jeweils in eine neue Spalte auslesen.
Kann mir jemand helfen?
DANKE

10
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Dateinamen auslesen inkl. Unterordner
02.10.2008 13:29:44
fcs
Hallo markus,
hier eine leicht modifizierte Variante aus meinem Fundus.
Ansonsten kannst du ja den Teil zum Wählen des Ordners in deine Routine einbauen.
Gruß
Franz

Dim FSO, FO, FU, F
Dim lRow As Long
Dim icol As Integer
Sub Dateien_in_Verzeichnissen_Listen()
Dim varAuswahl As Variant, strDir As String
varAuswahl = Application.GetOpenFilename(Title:="Bitte Ordner wählen und dann abbrechen")
strDir = VBA.CurDir
If MsgBox(strDir & " auslesen?", vbOKCancel) = vbCancel Then Exit Sub
Application.ScreenUpdating = False
Set FSO = CreateObject("Scripting.FileSystemObject")
ActiveSheet.UsedRange.Clear
icol = 0
lRow = 0
lRow = lRow + 1
icol = icol + 1
Cells(lRow, icol) = strDir 'gewählten Ordner eintragen
Call DateienListen(strPath:=strDir)
GetSubFolders strDir
Application.ScreenUpdating = True
MsgBox "Fertig"
End Sub
Function GetSubFolders(Pfad)
Set FO = FSO.GetFolder(Pfad)
Set FU = FO.SubFolders
On Error Resume Next
For Each F In FU
lRow = lRow + 1
icol = icol + 1
Cells(lRow, icol) = F.Name 'Ordnername
Cells(lRow, icol).Interior.ColorIndex = 6           'gelb einfärben
If IsEmpty(F) Then 'Probleme beim Zugriff auf Unterordner
Cells(lRow, icol) = "!keine Leseberechtigung!"
icol = icol - 1
Else
If DateienListen(strPath:=F.Path) = False Then
Cells(lRow, icol) = "!Problem beim Dateien lesen!"
End If
End If
GetSubFolders F.Path
Next
icol = icol - 1
End Function
Private Function DateienListen(strPath As String) As Boolean
Dim objFile
On Error GoTo FEHLER
DateienListen = True
With Application.FileSearch
.NewSearch
.LookIn = strPath
.SearchSubFolders = False
.FileType = msoFileTypeAllFiles
If .Execute() > 0 Then
For Each objFile In .FoundFiles
lRow = lRow + 1
Cells(lRow, icol + 1) = Replace(objFile, IIf(Right(strPath, 1) = "\", strPath, _
strPath & "\"), "")
Next
End If
End With
Exit Function
FEHLER:
'Fehler beim Auslesen des Ordners
DateienListen = False
End Function


Anzeige
AW: Dateinamen auslesen inkl. Unterordner
02.10.2008 14:05:51
Markus
Danke schonmal an dich Franz.
Klappt schon ganz gut, gefällt mir super mit dem Ordnernamen hervorgehoben usw.
Nur nen kleines Problem noch (zumindest für mich) was muss ich umändern das jeder neue Unterordner
wieder in der Zeile 1 anfängt, also Überschrift is gleich Ordnername in Zeile 1 darunter wieder die Dateinamen.
Danke
AW: Dateinamen auslesen inkl. Unterordner
02.10.2008 16:04:11
fcs
Hallo Markus,
mit dieser Variante werden alle Unterordner nebeneinander ausgegeben.
Allerdings ist dann die Ordnerstruktur nicht mehr genau wiedergegeben, wenn ein Unterordner weitere Unterordner enthält. Die angepassten Zeilen sind markiert.
Gruß
Franz

Dim FSO, FO, FU, F
Dim lRow As Long
Dim icol As Integer
Sub aDateien_in_Verzeichnissen_Listen()
Dim varAuswahl As Variant, strDir As String
varAuswahl = Application.GetOpenFilename(Title:="Bitte Ordner wählen und dann abbrechen")
strDir = VBA.CurDir
If MsgBox(strDir & " auslesen?", vbOKCancel) = vbCancel Then Exit Sub
Application.ScreenUpdating = False
Set FSO = CreateObject("Scripting.FileSystemObject")
ActiveSheet.UsedRange.Clear
icol = 0
lRow = 0
lRow = lRow + 1
icol = icol + 1
Cells(lRow, icol) = strDir 'gewählten Ordner eintragen
Call aDateienListen(strPath:=strDir)
aGetSubFolders strDir
Application.ScreenUpdating = True
MsgBox "Fertig"
End Sub
Function aGetSubFolders(Pfad)
Set FO = FSO.GetFolder(Pfad)
Set FU = FO.SubFolders
On Error Resume Next
For Each F In FU
lRow = 1 '                                     ###
icol = icol + 1
Cells(lRow, icol) = F.Name 'Ordnername
Cells(lRow, icol).Interior.ColorIndex = 6           'gelb einfärben
If IsEmpty(F) Then 'Probleme beim Zugriff auf Unterordner
Cells(lRow, icol) = "!keine Leseberechtigung!"
'      icol = icol - 1'                                     ###
Else
If aDateienListen(strPath:=F.Path) = False Then
Cells(lRow, icol) = "!Problem beim Dateien lesen!"
End If
End If
aGetSubFolders F.Path
Next
'  icol = icol - 1 '                                     ###
End Function
Private Function aDateienListen(strPath As String) As Boolean
Dim objFile
On Error GoTo FEHLER
aDateienListen = True
With Application.FileSearch
.NewSearch
.LookIn = strPath
.SearchSubFolders = False
.FileType = msoFileTypeAllFiles
If .Execute() > 0 Then
For Each objFile In .FoundFiles
lRow = lRow + 1
Cells(lRow, icol) = Replace(objFile, IIf(Right(strPath, 1) = "\", strPath, _
strPath & "\"), "") '                                     ###
Next
End If
End With
Exit Function
FEHLER:
'Fehler beim Auslesen des Ordners
aDateienListen = False
End Function


Anzeige
AW: Dateinamen auslesen inkl. Unterordner
06.10.2008 11:20:11
Markus
Hallo,
super danke funzt soweit prima.
Könntest du mir noch weiterhelfen in dem ich alle Dateien mit Hyperlink versehen kann.
DANKE
AW: Dateinamen auslesen inkl. Unterordner
06.10.2008 12:10:00
fcs
Hallo Markus,
um Hyperlinks einzufügen muss du die nachfolgende Prozedur anpassen.
gruß
Franz

Private Function aDateienListen(strPath As String) As Boolean
Dim objFile
On Error GoTo FEHLER
aDateienListen = True
With Application.FileSearch
.NewSearch
.LookIn = strPath
.SearchSubFolders = False
.FileType = msoFileTypeAllFiles
If .Execute() > 0 Then
For Each objFile In .FoundFiles
lRow = lRow + 1
Cells(lRow, icol) = Replace(objFile, IIf(Right(strPath, 1) = "\", strPath, _
strPath & "\"), "") '                                     ###
'hyperlink einfügen
ActiveSheet.Hyperlinks.Add Anchor:=Cells(lRow, icol), Address:=objFile
Next
End If
End With
Exit Function
FEHLER:
'Fehler beim Auslesen des Ordners
aDateienListen = False
End Function


Anzeige
AW: Dateinamen auslesen inkl. Unterordner
06.10.2008 12:51:00
Markus
Super Danke,
nun gleich das nächste Problem(für mich)
Hab zu deinem Makro ein weiteres von mir eingefügt das die Tabelle1 (ausgelesene Ordner) in die
Tabelle2 sortiert.
Möchte diese sortierte Tabelle2 mit Hyperlinks belegen
wie muss ich das schreiben
Hyperlink= Pfad aus zelle a1 + Text aus B1 + Zelleneintrag
Zelle A1 ist der Pfad zum Hauptordner, Zelle B1 ist der Unterordnername und dann die Dateinamen aus den Zellen anfügen.
DANKE
AW: Dateinamen auslesen inkl. Unterordner
06.10.2008 13:28:35
fcs
Hallo Markus,
um nachträglich die Hyperlinks einzufügen braucht es dann mehrere in einander geschachtelte Schleifen.
gruß
Franz

Sub HyperLinks()
Dim lngZeile As Long, lngSpalte As Long, wks As Worksheet, intI As Integer
Dim strPfad As String
Set wks = ActiveSheet
With wks
For lngSpalte = 1 To .Cells(1, .Columns.Count).End(xlToLeft).Column
'Pfad aus Werten in Zeile 1 ermitteln
For intI = 1 To lngSpalte
strPfad = .Cells(1, intI).Text & "\"
Next
'hyperlinks einfügen
For lngZeile = 2 To .Cells(.Rows.Count, lngSpalte).End(xlUp).Row
ActiveSheet.HyperLinks.Add Anchor:=.Cells(lngZeile, lngSpalte), _
Address:=strPfad & .Cells(lngZeile, lngSpalte).Text
Next
Next
End With
End Sub


Anzeige
AW: Dateinamen auslesen inkl. Unterordner
06.10.2008 14:00:42
Markus
Super klasse jetzt komm ich weiter.
Kniefall, Danke, Respekt
Danke für deine Zeit und Hilfe.
AW: Dateinamen auslesen inkl. Unterordner
07.10.2008 13:39:31
Markus
Hallo,
wieder mal ein neues Problem.
Wenn ich die Ordner auslese von meiner Festplatte funktioniert alles einwandfrei dann steht nur der Dateiname in der Spalte.
Wenn ich aber über ein Netzwerk auslese dann steht immer der kpl. Pfad in der Spalte.
Kann es sein das es damit zu tun hat das der Netzwerkpfad mit nem Doppel Backslash beginnt und nicht mit nem Laufwerksbuchstaben.
Hoffe nochmal um Hilfe.
Danke
AW: Dateinamen auslesen inkl. Unterordner
07.10.2008 16:32:00
fcs
Hallo Markus,
das problem ist, dass beim Einlesen der Pfade Mischmasch bzgl. Groß-/Kleinschreibung entsteht, so dass die Ersetzung des Pfades in der Funktion nicht korrekt erfolgen kann.
Ich hab die Funktion nochmals angepasst.
Gruß
Franz

Private Function aDateienListen(strPath As String) As Boolean
Dim objFile
On Error GoTo FEHLER
aDateienListen = True
With Application.FileSearch
.NewSearch
.LookIn = strPath
.SearchSubFolders = False
.FileType = msoFileTypeAllFiles
If .Execute() > 0 Then
For Each objFile In .FoundFiles
lRow = lRow + 1
Cells(lRow, icol) = IIf(Right(strPath, 1) = "\", Mid(objFile, Len(strPath) + 1), _
Mid(objFile, Len(strPath) + 2)) '                                     ###
'oder alles auf Kleinschreibung umsetzen
'        Cells(lRow, icol) = Replace(LCase(objFile), IIf(Right(LCase(strPath), 1) = "\", _
LCase(strPath), LCase(strPath) & "\"), "") '                          ###
'hyperlink einfügen
ActiveSheet.HyperLinks.Add Anchor:=Cells(lRow, icol), Address:=objFile
Next
End If
End With
Exit Function
FEHLER:
'Fehler beim Auslesen des Ordners
aDateienListen = False
End Function


Anzeige

34 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige