VBA: Folder & File Lister

[OsVenator]

Hi, i'm using the following VBA script from the Internet. (I am not yet allowed to post links..)

Option Explicit 
Private iColumn As Integer 
 
 
Sub TestListFolders(strPath As String, Optional bFolders As Boolean = True) 
     
    Application.ScreenUpdating = False 
     
    Cells.Delete 
     
    Range("A1").Select 
    iColumn = 1 
     
     ' add headers
    With Range("A1") 
        .Formula = "Folder contents: " & strPath 
        .Font.Bold = True 
        .Font.Size = 12 
    End With 
     
    If Right(strPath, 1) <> "\" Then 
        strPath = strPath & "\" 
    End If 
     
    ListFolders strPath, bFolders 
     
    Application.ScreenUpdating = True 
     
End Sub 
 
Sub ListFolders(SourceFolderName As String, IncludeSubfolders As Boolean) 
     ' lists information about the folders in SourceFolder
     ' example: ListFolders "C:\", True
    Dim FSO As Scripting.FileSystemObject 
    Dim SourceFolder As Scripting.Folder, SubFolder As Scripting.Folder 
    Dim r As Long 
    Dim strfile As String 
     
    Set FSO = New Scripting.FileSystemObject 
    Set SourceFolder = FSO.GetFolder(SourceFolderName) 
     
     'line added by dr for repeated "Permission Denied" errors
     
    On Error Resume Next 
     
    iColumn = iColumn + 1 
     
     ' display folder properties
    ActiveCell.Offset(1).Select 
     
    With Cells(ActiveCell.Row, iColumn) 
        .Formula = SourceFolder.Name 
        .Font.ColorIndex = 11 
        .Font.Bold = True 
         
        .Select 
    End With 
     
    strfile = Dir(SourceFolder.Path & "\*.*") 
     
    If strfile <> vbNullString Then 
        ActiveCell.Offset(0, 1).Select 
        Do While strfile <> vbNullString 
            ActiveCell.Offset(1).Select 
            ActiveCell.Value = strfile 
            strfile = Dir 
             
        Loop 
        ActiveCell.Offset(0, -1).Select 
         
    End If 
     
     '    Cells(r, 2).Formula = SourceFolder.Name
     '    Cells(r, 3).Formula = SourceFolder.Size
     '    Cells(r, 4).Formula = SourceFolder.SubFolders.Count
     '    Cells(r, 5).Formula = SourceFolder.Files.Count
     '    Cells(r, 6).Formula = SourceFolder.ShortName
     '    Cells(r, 7).Formula = SourceFolder.ShortPath
    If IncludeSubfolders Then 
        For Each SubFolder In SourceFolder.SubFolders 
            ListFolders SubFolder.Path, True 
             
            iColumn = iColumn - 1 
        Next SubFolder 
        Set SubFolder = Nothing 
    End If 
     
    Set SourceFolder = Nothing 
    Set FSO = Nothing 
     
End Sub

So I get the following overview of the folders and contained file:
Lister01.jpg

But I would like to get an overview, which looks like this:
Lister02.jpg

Unfortunately I have not succeeded in filling up the lines so far
Maybe someone can help me with this problem.
I really appreciate any help you can provide and I hope that no major change in the code is necessary.

Best regards
Os

[mana]

Sub TestListFolders(strPath As String, Optional bFolders As Boolean = True)
     
    Application.ScreenUpdating = False
     
    Cells.Delete
     
    Range("A1").Select
    iColumn = 1
     
     ' add headers
    With Range("A1:B1")     '#
        .Formula = Array("Folder contents: ", strPath)     '#
        .Font.Bold = True
        .Font.Size = 12
    End With
     
    If Right(strPath, 1) <> "\" Then
        strPath = strPath & "\"
    End If
     
    ListFolders strPath, bFolders
     
    Application.ScreenUpdating = True
     
End Sub
 
Sub ListFolders(SourceFolderName As String, IncludeSubfolders As Boolean)
     ' lists information about the folders in SourceFolder
     ' example: ListFolders "C:\", True
    Dim FSO As Scripting.FileSystemObject
    Dim SourceFolder As Scripting.Folder, SubFolder As Scripting.Folder
    Dim r As Long
    Dim strfile As String
     
    Set FSO = New Scripting.FileSystemObject
    Set SourceFolder = FSO.GetFolder(SourceFolderName)
     
     'line added by dr for repeated "Permission Denied" errors
     
    On Error Resume Next
     
     ' display folder properties
    ActiveCell.Offset(1).Select
     
    With Cells(ActiveCell.Row, iColumn + 1)     '#
        .Formula = SourceFolder.Name
        .Font.ColorIndex = 11
        .Font.Bold = True
              
        .Select
        writeParentfolder     '#


    End With
    iColumn = iColumn + 1     '#
     
    strfile = Dir(SourceFolder.Path & "\*.*")
     
    If strfile <> vbNullString Then
        ActiveCell.Offset(0, 1).Select
        Do While strfile <> vbNullString
            ActiveCell.Offset(1).Select
            ActiveCell.Value = strfile
            
            writeParentfolder     '#
            
            strfile = Dir
             
        Loop
        ActiveCell.Offset(0, -1).Select
         
    End If


    If IncludeSubfolders Then
        For Each SubFolder In SourceFolder.SubFolders
            ListFolders SubFolder.Path, True
             
            iColumn = iColumn - 1
        Next SubFolder
        Set SubFolder = Nothing
    End If
    
    Set SourceFolder = Nothing
    Set FSO = Nothing
     
End Sub


Sub writeParentfolder()
    Dim i As Long
    
    For i = 2 To iColumn
        With Cells(ActiveCell.Row, i)
            .Value = .End(xlUp).Value
            .Font.ColorIndex = 11
            .Font.Bold = True
        End With
    Next
    
End Sub