List all subfolders in a folder

[YasserKhalil]

Hello everyone
I have the following code that does two tasks: First, if the last parameter is True (to list all the files in folders and subfolders) and this is done well
Second, if the last parameter is False (to list all the folders and subfolders in a main folder)
Here's my try till now

Code: Select all

Sub Test_ListFolders()
Dim fso As Object, sPath As String
 Set fso = CreateObject("Scripting.FileSystemObject")
        With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show = -1 Then sPath = fso.GetFolder(.SelectedItems(1)).Path Else Exit Sub
    End With

With shHelper.Columns("G:H")
    .ClearContents: .NumberFormat = "@"
    End With
    ListFilesInFolder sPath, True, False
End Sub



Sub ListFilesInFolder(sourceFolderName As String, includeSubfolders As Boolean, ByVal bFiles As Boolean)
    Dim fileItem As Object, subFolder As Object, r As Long
    With shHelper
        r = .Range(IIf(bFiles, "A", "G") & .Rows.Count).End(xlUp).Row + 1
        r = IIf(IIf(bFiles, .Range("A1").Value, .Range("G1").Value) = Empty, 1, r)
    End With

    With CreateObject("Scripting.FileSystemObject")
        With .GetFolder(sourceFolderName)
            If bFiles Then
            For Each fileItem In .Files
                shHelper.Cells(r, 1) = Split(fileItem.Name, ".")(0)
                    shHelper.Cells(r, 2) = fileItem.Path
                    r = r + 1
            Next fileItem
            End If
            If includeSubfolders Then
                For Each subFolder In .SubFolders
                ListFilesInFolder subFolder.Path, True, bFiles
                If bFiles = False Then
                        shHelper.Cells(r, 7) = subFolder.Name
                    shHelper.Cells(r, 8) = subFolder.Path
                    r = r + 1
                    End If
                Next subFolder
            End If
        End With
    End With
End Sub

The code works well for the second task but only the subfolders in the main folder. What I expect is to list any subfolder even if inside a subfolder

[HansV]

It works as intended for me. Do you get an error message?

I selected C:\Program files (x86)\Common Files. As you can see, Microsoft Shared is listed, but also subfolders of Microsoft Shared (and the list goes deeper).

S2135.png

[YasserKhalil]

Thanks a lot, Mr. Hans
Can you create a folder on the desktop and create some subfolders inside? On my side, I didn't get the subfolders correctly. That's weird

[HansV]

Hmmm - the code writes all subfolders to row 1. Let's see...

[HansV]

Try this:

Code: Select all

Dim r As Long

Sub Test_ListFolders()
    Dim fso As Object, sPath As String
    Set fso = CreateObject("Scripting.FileSystemObject")
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show = -1 Then sPath = fso.GetFolder(.SelectedItems(1)).Path Else Exit Sub
    End With
    With shHelper.Columns("G:H")
        .ClearContents: .NumberFormat = "@"
    End With
    r = 1
    ListFilesInFolder sPath, True, False
End Sub

Sub ListFilesInFolder(sourceFolderName As String, includeSubfolders As Boolean, ByVal bFiles As Boolean)
    Dim fileItem As Object, subFolder As Object

    With CreateObject("Scripting.FileSystemObject")
        With .GetFolder(sourceFolderName)
            If bFiles Then
                For Each fileItem In .Files
                    shHelper.Cells(r, 1) = Split(fileItem.Name, ".")(0)
                    shHelper.Cells(r, 2) = fileItem.Path
                    r = r + 1
                Next fileItem
            End If
            If includeSubfolders Then
                For Each subFolder In .SubFolders
                    ListFilesInFolder subFolder.Path, True, bFiles
                    If bFiles = False Then
                        shHelper.Cells(r, 7) = subFolder.Name
                        shHelper.Cells(r, 8) = subFolder.Path
                        r = r + 1
                    End If
                Next subFolder
            End If
        End With
    End With
End Sub

[YasserKhalil]

Thanks a lot, Mr. Hans
I have found another code that I could manage to modify to do the two tasks

Code: Select all

Dim fso As Object

Sub Test()
    Dim sPath As String
    Set fso = CreateObject("Scripting.FileSystemObject")
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show = -1 Then sPath = fso.GetFolder(.SelectedItems(1)).Path Else Exit Sub
    End With
    ListFilesFolders sPath, shHelper, 1, True
    ListFilesFolders sPath, shHelper, 1, False
End Sub

Sub ListFilesFolders(ByVal sPath As String, ByVal sh As Worksheet, ByVal iFirstRow As Long, ByVal bFiles As Boolean)
    Dim queue As Collection, oFolder As Object, oSubfolder As Object, oFile As Object
    Set queue = New Collection
    queue.Add fso.GetFolder(sPath)
    Do While queue.Count > 0
        Set oFolder = queue(1)
        queue.Remove 1
        For Each oSubfolder In oFolder.SubFolders
            queue.Add oSubfolder
            If bFiles = False Then
                sh.Cells(iFirstRow, 7).Value = oSubfolder.Name
                sh.Cells(iFirstRow, 8).Value = oSubfolder.Path
                iFirstRow = iFirstRow + 1
            End If
        Next oSubfolder
        For Each oFile In oFolder.Files
            If bFiles Then
                sh.Cells(iFirstRow, 1).Value = Split(oFile.Name, ".")(0)
                sh.Cells(iFirstRow, 2).Value = oFile.Path
                iFirstRow = iFirstRow + 1
            End If
        Next oFile
    Loop
End Sub

[HansV]

Great!

[YasserKhalil]

Sorry, I didn't see your answer. Your code is great too. Thank you very much for the great support.

[YasserKhalil]

How can I control the level .. I mean how to add a variable in the public procedure to make it possible to get only the first level of files in the main folder only?

[HansV]

Do you still want to list all deeper-level subfolders?

[YasserKhalil]

I want to make it more flexible. Now the code deals with all the deeper levels, but I want to add a boolean variable to make it possible to deal with only the main folder
I want to modify the following code

Code: Select all

Dim a(1 To 100000, 1 To 2), fso As Object

Sub Test()
    Dim sPath As String
    Set fso = CreateObject("Scripting.FileSystemObject")
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show = -1 Then sPath = fso.GetFolder(.SelectedItems(1)).Path Else Exit Sub
    End With
    Erase a
    ListFilesFolders sPath, shHelper, 1, 1, True
    Erase a
    ListFilesFolders sPath, shHelper, 1, 7, False
End Sub


Sub ListFilesFolders(ByVal sPath As String, ByVal shHelper As Worksheet, ByVal iFirstRow As Long, ByVal iFirstCol As Long, ByVal bFiles As Boolean)
    Dim col As Collection, oFolder As Object, oSubfolder As Object, oFile As Object, n As Long
    With shHelper.Columns(iFirstCol).Resize(, 1)
        .ClearContents: .NumberFormat = "@"
    End With
    Set col = New Collection
    col.Add fso.GetFolder(sPath)
    Do While col.Count > 0
        Set oFolder = col(1)
        col.Remove 1
        For Each oSubfolder In oFolder.SubFolders
            col.Add oSubfolder
            If bFiles = False Then
                n = n + 1
                a(n, 1) = oSubfolder.Name
                a(n, 2) = oSubfolder.Path
            End If
        Next oSubfolder
        For Each oFile In oFolder.Files
            If bFiles Then
                n = n + 1
                a(n, 1) = Split(oFile.Name, ".")(0)
                a(n, 2) = oFile.Path
            End If
        Next oFile
    Loop
    Application.ScreenUpdating = False
        If n > 0 Then shHelper.Cells(iFirstRow, iFirstCol).Resize(n, UBound(a, 2)).Value = a
    Application.ScreenUpdating = True
End Sub

[HansV]

Wouldn't it be easier to use a simple Dir loop if you don't want to process deeper levels anyway?

[YasserKhalil]

I just want to make the public procedure more flexible as all these tasks are needed.

[YasserKhalil]

I could control it as for the files

Code: Select all

Sub ListFilesFolders(ByVal sPath As String, ByVal shHelper As Worksheet, ByVal iFirstRow As Long, ByVal iFirstCol As Long, ByVal bFiles As Boolean, ByVal bLevel As Boolean)

and

Code: Select all

        Next oFile
        If bLevel = False Then Exit Do
    Loop

Calling it like that

Code: Select all

ListFilesFolders sPath, shHelper, 1, 1, True, False

[YasserKhalil]

This is the final code

Code: Select all

Dim a(1 To 100000, 1 To 2), fso As Object

Sub Test()
    Dim sPath As String
    Set fso = CreateObject("Scripting.FileSystemObject")
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show = -1 Then sPath = fso.GetFolder(.SelectedItems(1)).Path Else Exit Sub
    End With
    Erase a
    ListFilesFolders sPath, shHelper, 1, 1, True, True
    Erase a
    ListFilesFolders sPath, shHelper, 1, 7, False, True
End Sub

Sub ListFilesFolders(ByVal sPath As String, ByVal shHelper As Worksheet, ByVal iFirstRow As Long, ByVal iFirstCol As Long, ByVal bFiles As Boolean, ByVal bLevel As Boolean)
    Dim col As Collection, oFolder As Object, oSubfolder As Object, oFile As Object, n As Long
    With shHelper.Columns(iFirstCol).Resize(, 1)
        .ClearContents: .NumberFormat = "@"
    End With
    Set col = New Collection
    col.Add fso.GetFolder(sPath)
    Do While col.Count > 0
        Set oFolder = col(1)
        col.Remove 1
        For Each oSubfolder In oFolder.SubFolders
            col.Add oSubfolder
            If bFiles = False Then
                n = n + 1
                a(n, 1) = oSubfolder.Name
                a(n, 2) = oSubfolder.Path
            End If
        Next oSubfolder
        If bFiles = False And bLevel = False Then Exit Do
        For Each oFile In oFolder.Files
            If bFiles Then
                n = n + 1
                a(n, 1) = Split(oFile.Name, ".")(0)
                a(n, 2) = oFile.Path
            End If
        Next oFile
        If bLevel = False Then Exit Do
    Loop
    Application.ScreenUpdating = False
        If n > 0 Then shHelper.Cells(iFirstRow, iFirstCol).Resize(n, UBound(a, 2)).Value = a
    Application.ScreenUpdating = True
End Sub

[YasserKhalil]

Is it possible to make the code much faster (improve the code) .. as some folders have more than 150,000 files and this take too much time

[HansV]

I don't think so, except perhaps with low-level API functions to read the directory structure, but I cannot help you with that.

[SpeakEasy]

Yep, dealing with a large number of entries is NOT the filesystemobject's strength.

But how can we improve on this, given that the other VBA filehandling methods don't give us an easy (or fast) way to iterate through the folder hierarchy (particularly since Dir doesn't support recursion).

SO what are the alternatives. Well - API stuff is one way - and there are at least two seperate methods of using the APi for this: accesing the NTFS file handling functions, or bypassing the OS, and accessing the raw Master File Table directly (this is pretty much the fastes). But both metrhods are far from straightforward or free from risk

So what else can we do? Well, bothe the Command Prompt and Powershell have pretty fast commands to iterate through a folder hierarchy. My preference is Powershell, so here's an illustration of how it can be used in Excel (it is not a full solution):

Code: Select all

Option Explicit

Public Enum WalkOptions
    woFiles = 1 ' return files
    woDirectories = 2 ' return folders
    woFilesAndDirectories = woFiles Or woDirectories ' return files and folders
    woRecurse = 4 ' recurse through folder hierarchy sarting at selected root
    woEverything = woFilesAndDirectories Or woRecurse ' Recurse entire directory tree starting at selected root, returning all files and folders
End Enum

Private Sub ListFilesFolders3(strRootFolder As String, Optional Options As WalkOptions = woFiles + woRecurse)
    Dim powershell As String
    Dim strOptions As String
    Dim TargetCSV As String
    
    If Options > woEverything Or Options < woFiles Then Err.Raise 513, "Unrecognised Options"
    
    TargetCSV = "D:\Downloads\Results.csv"
    On Error Resume Next
        Workbooks("Results.csv").Close False
    On Error GoTo 0

    If (Options And woFiles) = woFiles Then strOptions = strOptions & " -file "
    If (Options And woDirectories) = woDirectories Then strOptions = strOptions & " -directory "
    If (Options And woFilesAndDirectories) = woFilesAndDirectories Then strOptions = ""
    If (Options And woRecurse) = woRecurse Then strOptions = strOptions & " -recurse "
    If (Options And woEverything) = woEverything Then strOptions = " -recurse "

    powershell = "powershell gci '" & strRootFolder & "'" & strOptions & " | Select  Basename, Fullname | Export-Csv " & TargetCSV & " -NoTypeInformation"

    CreateObject("WScript.Shell").Run powershell, 0, True
    Workbooks.Open TargetCSV
    Windows("Results.csv").Activate

End Sub

Public Sub Example()
    Dim sPath As String
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show = -1 Then sPath = .SelectedItems(1)
    End With
    ListFilesFolders3 sPath, woEverything ' Recurse entire directory tree starting at selected root, returning all files and folders
End Sub

On my data SSD this churns through about 148000 entries in approx 10 seconds or so. This is magnitudes of time better than the filesystemobject ...

[YasserKhalil]

Amazing. Thank you very much.
How can I put the results into a worksheet of the ThisWorkbook? I tried `TargetCSV = ThisWorkbook.FullName` and changed some lines, but couldn't get the results

[HansV]

PowerShell doesn't create Excel workbooks. It can create a text/csv file.
SpeakEasy's code opens the csv file in Excel.
You can then either save it as an Excel workbook or copy the data into the workbook running the code.