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:
20405

But I would like to get an overview, which looks like this:
20406

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