Dateiinformationen auslesen

Sub DateienAuflisten()
Dim i As Long
Dim objFileSystem As Object
Dim objVerzeichnis As Object
Dim objDateienliste As Object
Dim objDatei As Object
Dim Verzeichnis As String
Verzeichnis = ActiveWorkbook.Path
Set objFileSystem = CreateObject("scripting.FileSystemObject")
Set objVerzeichnis = objFileSystem.getfolder(Verzeichnis)
Set objDateienliste = objVerzeichnis.Files
i = 2
For Each objDatei In objDateienliste
If Not objDatei Is Nothing And Not Left(objDatei.Name, 1) = "~" Then
ActiveSheet.Cells(i, 2) = objDatei.Name
ActiveSheet.Cells(i, 1) = objVerzeichnis.Path
ActiveSheet.Cells(i, 4) = objVerzeichnis.Path & "\" & objDatei.Name
ActiveSheet.Cells(i, 3) = FileDateTime(objDatei)
i = i + 1
End If
Next objDatei
' Dateien in den Unterverzeichnissen auslesen '
Call UnterOrdnerAuslesen(objVerzeichnis)
End Sub

Sub UnterOrdnerAuslesen(ByVal strDateipfad As String)
Dim objFileSystem As Object
Dim objVerzeichnis As Object
Dim objUnterordner As Object
Dim objDatei2 As Object
Dim i As Long
Set objFileSystem = CreateObject("Scripting.FileSystemObject")
Set objVerzeichnis = objFileSystem.getfolder(strDateipfad)
For Each objUnterordner In objVerzeichnis.subfolders
For Each objDatei2 In objUnterordner.Files
If Cells(Rows.Count, 1).End(xlUp).Row > 1 Then
i = Cells(Rows.Count, 1).End(xlUp).Row + 1
Else
i = 2
End If
ActiveSheet.Cells(i, 2) = objDatei2.Name
ActiveSheet.Cells(i, 1) = objUnterordner.Path
ActiveSheet.Cells(i, 4) = objUnterordner.Path & "\" & objDatei2.Name
ActiveSheet.Cells(i, 3) = objDatei2.FileDateTime
i = i + 1
Next objDatei2
Call UnterOrdnerAuslesen(objUnterordner.Path)
Next objUnterordner
End Sub