Office: (Office 2019) VBA - Dateien auslesen und strukturiert ausgeben

Hallo zusammen,

ich möchte gerne eine Übersichtsdatei erstellen, welche ein Verzeichnis inklusive der Unterverzeichnisse ausliest und die darin enthaltenen Dateien in eine Excel Tabelle ausgibt.

Ich habe bereits einen sehr gut funktionierenden Code auf Excelbaby gefunden.

Code:

Option Explicit

Sub ListFile()
    ''Description: List all files in folder and sub-folders (include hidden ,read only...)
    ''Web Site: https://excelbaby.com
    ''Url: https://excelbaby.com/learn/excel-macro-list-all-files-in-folders-and-subfolders/

    Dim PathSpec As String
    PathSpec = ActiveWorkbook.Path  'Specify a folder
    If (PathSpec = "") Then PathSpec = SelectSingleFolder   'Browse for Folder to select a folder

    Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")    'Late Binding
    If (fso.FolderExists(PathSpec) = False) Then Exit Sub   'folder exist or not?

    Application.ScreenUpdating = False 'Disable Screen Updating to speed up macro
  
    Dim MySheetName As String
    MySheetName = "Files"   'Add a Sheet with name "Files"
    AddSheet (MySheetName)

    Dim FileType As String
    FileType = "*"   '*:all, or pdf, PDF, XLSX...
    FileType = UCase(FileType)

    Dim queue As Collection, oFolder As Object, oSubfolder As Object, oFile As Object
    Dim LastBlankCell As Long, FileExtension As String

    Set queue = New Collection
    queue.Add fso.getfolder(PathSpec) 'enqueue
  
    Do While queue.Count > 0
        Set oFolder = queue(1)
        queue.Remove 1 'dequeue
      
        For Each oSubfolder In oFolder.SubFolders   'loop all sub-folders
            queue.Add oSubfolder 'enqueue
            '...insert any folder processing code here...
        Next oSubfolder
      
        LastBlankCell = ThisWorkbook.Sheets(MySheetName).Cells(Rows.Count, 1).End(xlUp).Row + 1 'get the last blank cell of column A
      
        For Each oFile In oFolder.Files 'loop all files
            FileExtension = UCase(Split(oFile.Name, ".")(UBound(Split(oFile.Name, ".")))) 'get file extension, eg: TXT
            If (FileType = "*" Or FileExtension = FileType) Then
                With ThisWorkbook.Sheets(MySheetName)
                    .Cells(LastBlankCell, 1) = oFile 'Path
                    .Cells(LastBlankCell, 2) = oFolder 'Folder
                    .Cells(LastBlankCell, 3) = oFile.Name 'File Name
                    .Cells(LastBlankCell, 4) = FileExtension 'File Extension
                    .Cells(LastBlankCell, 5) = oFile.DateCreated 'Data Created
                    .Cells(LastBlankCell, 6) = oFile.DateLastAccessed 'Last Accessed
                    .Cells(LastBlankCell, 7) = oFile.DateLastModified 'Last Modified
                    .Cells(LastBlankCell, 8) = oFile.Size 'File Size
                    If (oFile.Attributes And 2) = 2 Then
                        .Cells(LastBlankCell, 9) = "TRUE" 'Is Hidden
                    Else
                        .Cells(LastBlankCell, 9) = "FALSE" 'Is Hidden
                    End If
                End With
                LastBlankCell = LastBlankCell + 1
            End If
        Next oFile
    Loop
  
    'Cells.EntireColumn.AutoFit  'Autofit columns width
    Application.ScreenUpdating = True

End Sub

Function SelectSingleFolder()
    'Select a Folder Path
  
    Dim FolderPicker As FileDialog
    Dim myFolder As String
  
    'Select Folder with Dialog Box
    Set FolderPicker = Application.FileDialog(msoFileDialogFolderPicker)
  
    With FolderPicker
        .Title = "Select A Single Folder"
        .AllowMultiSelect = False
        If .Show <> -1 Then Exit Function 'Check if user clicked cancel button
        SelectSingleFolder = .SelectedItems(1)
    End With
End Function

Function AddSheet(MySheetName As String)
    'Add a worksheet with custom name
  
    Dim Mysheet As Worksheet, F As Boolean
    For Each Mysheet In ThisWorkbook.Worksheets
        If Mysheet.Name = MySheetName Then
            Sheets(MySheetName).Cells.Delete
            F = True
            Exit For
        Else
            F = False
        End If
    Next
    If Not F Then Sheets.Add.Name = MySheetName
  
    'Add table header
    With Sheets(MySheetName)
        .Cells(1, 1) = "Path"
        .Cells(1, 2) = "Folder"
        .Cells(1, 3) = "File Name"
        .Cells(1, 4) = "File Extension"
        .Cells(1, 5) = "Data Created"
        .Cells(1, 6) = "Last Accessed"
        .Cells(1, 7) = "Last Modified"
        .Cells(1, 8) = "Size"
        .Cells(1, 9) = "Is Hidden"
    End With
End Function

Bei einer beispielhaften Verzeichnisstruktur:

Code:

Farben
|   Dateien auslesen und ausgeben.xlsm
|   
+---dunkle Farben
|       grau.txt
|       schwarz.txt
|       
\---helle Farben
        rosa.txt
        weiß.txt

sieht das Ergebnis so aus:


(Excel Datei im Anhang)

Mein Wunschwäre jedoch, dass es wie folgt aussieht


Die nicht benötigten Spalten bekomme ich selber weg. Was ich aber nicht hinbekomme, ist das die Unterverzeichnisse als Überschrift vorangestellt dargestellt werden, statt das der Pfad als eigene Spalte vorangestellt wird.

Hier wäre ich für einen Ratschlag sehr dankbar!

 

mache die Farbe mit bedingter Formatierung
=Und(A1<>"";Rest(Zeile();6)=0
für die anden Farben 1 bis 5

 

Hallo Hajo,

erst einmal vielen Dank für die Hilfe. Ich glaube ich habe mich unpräzise ausgedrückt bzw. das Beispiel mit den Farben war schlecht gewählt.

Es geht mir gar nicht um die Formatierung bzw. die Farben, sondern um den Output, den das Makro strukturell erzeugt.

Ich möchte, dass die Unterverzeichnisse als Überschriften über den Dateien angeordnet werden, statt als separate Spalte vor dem Dateinamen.