Option Explicit
Option Compare Text
' ************************************************************************************************
' Autor/en: http://www.online-vba.de - Marc Wershoven
' Verwendung der Quelltexte auf eigene Gefahr!
' Es gelten die Nutzungsbedingungen von www.online-vba.de!
' Original-Quelltext: www.online-vba.de/vba_readfolder.php
' ************************************************************************************************

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 MWDateienMitUnterordnernAuslesen

Public Sub MWDateienMitUnterordnernAuslesen()
     Set oSheet = Sheets.Add
     oSheet.Activate
     oSheet.Cells(1, 1).Select
     Call CreateHeadLinesAndFormat
     lRowCounter = 2
     Call MWReadSubFolder(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 MWReadSubFolder(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 MWReadSubFolder(oSubFolder.Path)
        
         Next oSubFolder
    
     End With
    
     Set oFSO = Nothing
     Set oFile = Nothing
     Set oFolder = Nothing
     Set oSubFolder = Nothing
End Sub