Dateinamen aus Ordner und SubOrdner in Excel

Forumthread: Dateinamen aus Ordner und SubOrdner in Excel

06.04.2017 16:21:12

Schnappauf

Hallo zusammen,
ich würde gerne die File-Namen eines Ordners, sowie dessen Sub-Ordner, in eine Excel schreiben.
Am besten wäre es wenn nur PDF und Excel-File-Namen (also .pdf und .xls) in die Excel-Tabelle geschrieben würden.
Folgenden Code habe ich schon angepasst, jedoch passiert bei der Ausführung nichts...

Function OrdnerDateienAuslesen(ByVal strOrdner As String)
Dim fso As Object
Dim objFld As Object
Dim SubFld As Object
Dim fld, file
Dim rs As DAO.Recordset
Dim db As DAO.Database
'Recordset referenzieren
Set db = CurrentDb
Set rs = db.OpenRecordset("Dateipfad", dbOpenDynaset)
'File-System-Object, Startordner, Unterordner referenzieren
Set fso = CreateObject("Scripting.FileSystemObject")
Set objFld = fso.GetFolder(strOrdner)
Set objSubFld = objFld.SubFolders
For Each fld In objSubFld
Set objFiles = fld.Files
For Each file In objFiles
rs.AddNew
'Neuen Pfad speichern
rs!dateiPfad = fld.Path
'Dateiname speichern
rs!Dateiname = file.Name
rs.Update
Next file
'Rekursiver Aufruf
OrdnerDateienAuslesen fld
Next fld
'Objektreferenzen zerstören
Set db = Nothing
rs.Close
Set fso = Nothing
Set objFld = Nothing
End Function

Ich habe die Funktion auch aus einem Forum, kenn mich leider noch nicht so gut aus.
Über Hilfe würde ich mich freuen, danke!

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

AW: Dateinamen aus Ordner und SubOrdner in Excel

06.04.2017 20:57:16

Dieter

Hallo Schnappauf,
du kannst das folgende Programm verwenden:


Dim fso As FileSystemObject
Dim zeile As Long
Dim ws As Worksheet
Sub Auflistung_FD_Unterverz()
Dim fd As FileDialog
Dim fol As Folder
Dim pfad As String
Set fd = Application.FileDialog(msoFileDialogFolderPicker)
fd.Title = "FileSystemObject_Demo - Verzeichnis auswählen"
fd.ButtonName = "&Übernehmen"
fd.InitialView = msoFileDialogViewDetails
fd.InitialFileName = ThisWorkbook.Path & "\"
If fd.Show = 0 Then
MsgBox Prompt:="Abbruch durch den Benutzer"
Exit Sub
End If
pfad = fd.SelectedItems(1)
Set ws = ThisWorkbook.Worksheets(1)
ws.UsedRange.ClearContents
Set fso = New FileSystemObject
Set fol = fso.GetFolder(pfad)
zeile = 1
Folder_abarbeiten Verzeichnis:=fol
Set fso = Nothing
End Sub
Sub Folder_abarbeiten(Verzeichnis As Folder)
Dim fil As File
Dim fol As Folder
' Alle pdf- und Excel-Dateien des Verzeichnisses auflisten
For Each fil In Verzeichnis.Files
If UCase$(fil.Name) Like "*.PDF" Or _
UCase$(fil.Name) Like "*.XL*" Then
If Left$(fil.Name, 1) = "=" Then
ws.Cells(zeile, "A") = "'" & fil.Path
Else
ws.Cells(zeile, "A") = fil.Path
End If
zeile = zeile + 1
End If
Next fil
' Alle Unterverzeichnisse des Verzeichnisses abarbeiten
For Each fol In Verzeichnis.SubFolders
Folder_abarbeiten Verzeichnis:=fol
Next fol
End Sub

Den Code zusammen in einen Modul kopieren.
Dann musst du noch einen Verweis auf die Bibliothek "Microsoft Scripting Runtime" setzen. Das machst du von der VBA-Oberfläche aus: Extras > Verweise... > Häkchen bei "Microsoft Scripting Runtime" setzen.
Viele Grüße
Dieter

AW: Dateinamen aus Ordner und SubOrdner in Excel

07.04.2017 09:47:37

Schnappauf

Danke für die Antwort!
Das klappt auch soweit. Nur würde ich gerne statt dem kompletten Dateipfad nur den Namen der Datei kopieren. Also bspw. in der Form "Dateinamen.pdf"
Außerdem würde ich es gerne verstehen und (wenn möglich) etwas einfacher halten. Mit folgendem Code kann klappt es, nur muss ich für jeden Unterordner den Code wieder kopieren und die zu durchsuchende Adresse anpassen:

Sub Test()
Dim fs As Object
Dim fVerz As Object
Dim fDatei As Object
Dim fdateien As Object
Dim strDat As String
Dim Zeile As Integer
Zeile = 3
Set fs = CreateObject("scripting.FileSystemObject")
Set fVerz = fs.getFolder("Adresse/Pfad")
Set fdateien = fVerz.Files
For Each fDatei In fdateien
If InStr(fDatei, "") > 0 Then
Zeile = Zeile + 1
Cells(Zeile, 3) = fDatei.Name
End If
Next fDatei
End Sub

Diesen Code verstehe ich soweit. Nur würde ich gerne automatisch noch die Unterordner in gleicher Weise durchsuchen und in Excel kopieren, sowie (wenn möglich) bei jedem Unterordner in Excel eine Zeile frei lassen...

AW: Dateinamen aus Ordner und SubOrdner in Excel

07.04.2017 21:31:19

Dieter

Hallo Schnappauf,
wenn du wirklich Unterordner bis zu beliebiger Tiefe einbeziehen willst, dann geht das nur rekursiv.
D.h. hier, dass sich das Programm "Folder_abarbeiten" für jedes Element der SubFolders-Auflistung selbst aufruft.
Ich habe dir jetzt das Programm so geändert, dass jeweils der Verzeichnisname und anschließend die Dateien ohne Verzeichnis aufgelistet werden. Vor dem Verzeichnisnamen erscheint jeweils eine Leerzeile.


Option Explicit
Dim fso As FileSystemObject
Dim zeile As Long
Dim ws As Worksheet
Sub Auflistung_FD_Unterverz_V2()
Dim fd As FileDialog
Dim fol As Folder
Dim pfad As String
Set fd = Application.FileDialog(msoFileDialogFolderPicker)
fd.Title = "FileSystemObject_Demo - Verzeichnis auswählen"
fd.ButtonName = "&Übernehmen"
fd.InitialView = msoFileDialogViewDetails
fd.InitialFileName = ThisWorkbook.Path & "\"
If fd.Show = 0 Then
MsgBox Prompt:="Abbruch durch den Benutzer"
Exit Sub
End If
pfad = fd.SelectedItems(1)
Set ws = ThisWorkbook.Worksheets(1)
ws.UsedRange.ClearContents
Set fso = New FileSystemObject
Set fol = fso.GetFolder(pfad)
zeile = 1
Folder_abarbeiten Verzeichnis:=fol
Set fso = Nothing
End Sub
Sub Folder_abarbeiten(Verzeichnis As Folder)
Dim fil As File
Dim fol As Folder
' Alle pdf- und Excel-Dateien des Verzeichnisses auflisten
If zeile > 1 Then
zeile = zeile + 1
End If
ws.Cells(zeile, "A") = Verzeichnis.Path
zeile = zeile + 1
For Each fil In Verzeichnis.Files
If UCase$(fil.Name) Like "*.PDF" Or _
UCase$(fil.Name) Like "*.XL*" Then
If Left$(fil.Name, 1) = "=" Then
ws.Cells(zeile, "A") = "'" & fil.Name
Else
ws.Cells(zeile, "A") = fil.Name
End If
zeile = zeile + 1
End If
Next fil
' Alle Unterverzeichnisse des Verzeichnisses abarbeiten
For Each fol In Verzeichnis.SubFolders
Folder_abarbeiten Verzeichnis:=fol
Next fol
End Sub

Einen echten Vereinfachungsansatz (jedenfalls nicht ohne Leistungseinschränkung) sehe ich leider nicht.
Ich füge auch meine Arbeitsmappe bei:
https://www.herber.de/bbs/user/112736.xlsm
Viele Grüße
Dieter

Infobox / Tutorial