Dateien und Verzeichnisse auslesen

Option Explicit
Option Compare Text
' Original-Quelltext unter: https://www.online-vba.de/dateinamen-und-verzeichnisse-auslesen
' Express-Hilfe für VBA unter https://www.online-vba.de/vba-expresshilfe
' Es gelten die Nutzungsbedingungen von Online-VBA.de

Const sRootPath As String = "C:\TEST" 'Pfad bitte anpassen ohne Trennzeichen am Ende!!!
Private lRowCounter As Long
Private oSheet As Object

'Start der Routine: Call OVBAde_DateienMitUnterordnernAuslesen

Public Sub OVBAde_DateienMitUnterordnernAuslesen()
    Set oSheet = Sheets.Add
    oSheet.Activate
    oSheet.Cells(1, 1).Select
    Call CreateHeadLinesAndFormat
    lRowCounter = 2
    Call OVBAde_ReadSubFolder(sRootPath)
    Set oSheet = Nothing
End Sub

Private Sub CreateHeadLinesAndFormat()
  Dim i As Long
    
    oSheet.Cells(1, 1) = "Pfad"
    oSheet.Cells(1, 2) = "Dateiname"
    oSheet.Columns(1).ColumnWidth = 40
    oSheet.Columns(2).ColumnWidth = 40
    
    For i = 1 To 2
        With oSheet
            .Cells(1, i).Interior.ColorIndex = 11
            .Cells(1, i).Font.Color = vbWhite
            .Cells(1, i).Font.Bold = True
        End With
    Next i
End Sub

Private Sub OVBAde_ReadSubFolder(ByVal sPath As String)
  Dim oFSO As Object
  Dim oFolder As Object
  Dim oSubFolder As Object
  Dim oFile As Object
    
    Set oFSO = CreateObject("Scripting.FileSystemObject")
    Set oFolder = oFSO.getfolder(sPath)
    
    With oSheet
    
        For Each oSubFolder In oFolder.subfolders
        
            'Alle Dateien auflisten
            For Each oFile In oSubFolder.Files
                .Cells(lRowCounter, 1) = oSubFolder.Path
                .Cells(lRowCounter, 2) = oFile.Name
                lRowCounter = lRowCounter + 1
            Next oFile
            
            'Alle Unterverzeichnisse verarbeiten (rekursiv)
            Call OVBAde_ReadSubFolder(oSubFolder.Path)
        
        Next oSubFolder
    
    End With
    
    Set oFSO = Nothing
    Set oFile = Nothing
    Set oFolder = Nothing
    Set oSubFolder = Nothing
End Sub