Guten Morgen,

so evtl.?

Option Explicit
 
'//Erforderliche Verweise (Extras -> Verweise)
'//-Microsoft Scripting Runtime
 
'//Konstanten/Settings
'//Startpfad für Auflistung
Private PFAD As String
'//Arbeitsblatt in dem die Liste erstellt wird
Private Const WORKSHEET_NAME As String = "Tabelle1"
 
Public Sub getAllFiles()
    Dim fso As New FileSystemObject
    PFAD = ThisWorkbook.Path
     
    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
        .Cells.Clear
        .Range("A1") = "Dateiname"
        .Range("B1") = "Verzeichnis"
        .Range("C1") = "Übergeordnetes Verzeichnis 1"
        .Range("D1") = "Übergeordnetes Verzeichnis 2"
    End With
     
    listFiles PFAD
    wks.Columns("A:D").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, 2) = fo.Name
        Set fo = fso.GetFolder(fso.GetParentFolderName(fo.Path))
        .Cells(l, 3) = fo.Name
        Set fo = fso.GetFolder(fso.GetParentFolderName(fo.Path))
        .Cells(l, 4) = fo.Name
    End With
     
    Set wks = Nothing
    Set fo = Nothing
End Sub

Gruß