Option Explicit
Private Const PFAD As String = "G:\Test"
Private Const WORKSHEET_NAME As String = "Tabelle1"
Public Sub getAllFiles()
Dim fso As New FileSystemObject
If Not fso.FolderExists(PFAD) Then
MsgBox "Das angegebene Verzeichnis existiert nicht..", vbInformation
GoTo cleanUp
End If
Dim wks As Worksheet
Set wks = Worksheets(WORKSHEET_NAME)
With wks
.Range("A1") = "Dateiname"
.Range("B1") = "Hauptfirma"
.Range("C1") = "Firma"
End With
listFiles PFAD
wks.Columns("A:C").AutoFit
cleanUp:
If Not fso Is Nothing Then Set fso = Nothing
If Not wks Is Nothing Then Set wks = Nothing
End Sub
Private Sub listFiles(ByVal p As String)
Dim fso As New FileSystemObject
Dim fo As Folder, fo1 As Folder
Dim f As File
Set fo = fso.GetFolder(p)
For Each f In fo.Files
addNewFileToList f.Path
Next
For Each fo1 In fo.SubFolders
listFiles fo1.Path
Next
Set fo = Nothing
Set fso = Nothing
End Sub
Private Sub addNewFileToList(ByVal p As String)
Dim fso As New FileSystemObject
Dim fo As Folder
Dim wks As Worksheet
Dim l As Long
Set wks = Worksheets(WORKSHEET_NAME)
l = wks.Cells(wks.Rows.Count, 1).End(xlUp).Row + 1
With wks
.Cells(l, 1) = fso.GetFileName(p)
.Hyperlinks.Add .Cells(l, 1), p
Set fo = fso.GetFolder(fso.GetParentFolderName(p))
.Cells(l, 3) = fo.Name
Set fo = fso.GetFolder(fso.GetParentFolderName(fo.Path))
.Cells(l, 2) = fo.Name
End With
Set wks = Nothing
Set fo = Nothing
End Sub