Option Explicit
Option Compare Text
' ****************************************************************
' Autor/en und Original-Quelltext unter:
' https://www.online-vba.de/vba_readfolder.php
' Verwendung der Quelltexte auf eigene Gefahr!
' Es gelten die Nutzungsbedingungen von https://www.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