Search/List subfolders using Dir

I prefer (where possible) to use Dir over FSO to take advantage of better running speed.

However FSO has the edge on Dir in that Dir is unable to natively process any files/folders below the original starting folder path. (A better way of putting it = Dir cant search the contents of any subfolders in the folder it is processing)

I have adapted code to return folder names using Dir (see http://www.excelforum.com/excel-prog...using-fso.html ).

I am not that good at writing recursive functions (especially when the output has to go to the same dynamic array each loop!) So could some kind forum user please adapt my adapted code so that it can process all subfolders and output the result to a single array?

Hello mc84excel ,

Try this macro I wrote using the Dir function.

Recursively List Files and Folders Using Dir

Private SubFolders As Collection

Sub ListFiles(ByVal Folder_Path As String, ByRef Rng As Range, Optional ByVal Include_Subfolders As Boolean)

    Dim FileName    As String
    Dim FilePath    As String
    Dim Filespec    As String
    Dim row         As Long
    Dim SubFolder   As Variant
        
        If SubFolders Is Nothing Then Set SubFolders = New Collection
    
        FilePath = IIf(Right(Folder_Path, 1) <> "\", Folder_Path & "\", Folder_Path)
        FileName = Dir(FilePath & "*.*", vbDirectory)
    
        Do While FileName <> ""
            Filespec = FilePath & FileName
            
            If (GetAttr(Filespec) And vbDirectory) = vbDirectory Then
                If FileName <> "." And FileName <> ".." And Include_Subfolders Then SubFolders.Add Filespec
                If row = 0 Then
                    Rng.Offset(row, 0).Font.Bold = True
                    Rng.Offset(row, 0) = FilePath
                End If
            Else
                row = row + 1
                Rng.Offset(row, 1) = FileName
            End If
            
            FileName = Dir()
        Loop
        
        If Include_Subfolders And SubFolders.Count <> 0 Then
            SubFolder = SubFolders.Item(1)
            SubFolders.Remove 1
            Call ListFiles(SubFolder, Rng.Offset(row + 1, 0), True)
        End If
      
End Sub

Example of Calling the Macro
This will list all files and subfolders on the ActiveSheet in columns "A:B". Folder names are in bold in "A" and file names in "B".

Sub ListFilesTest()

  Dim MyPath As String
  
    MyPath = "C:\Test"   ' <<<<< Change Folder to one you want to use.

    ListFiles MyPath, Range("A1"), True
    
End Sub

Thanks for the suggestion Leith. Your code is interesting (I never learnt collections). I tried your code but it crashes Excel somewhere after 12,000 lines.

Also whenever the code encounters a folder that ends with a space (which Windows treats these as invalid see https://msdn.microsoft.com/en-au/lib...(v=vs.85).aspx ), VBA throws an Error 53. I added an error handler but it still crashes.

Hello mc84excel,

I updated the code to handle errors for both files and folders. I tested this on my machine using "C:\Users". It filled 36,020 rows without crashing.

Private SubFolders As Collection

Sub ListFiles(ByVal Folder_Path As String, ByRef Rng As Range, Optional ByVal Include_Subfolders As Boolean)

    Dim FileName    As String
    Dim FilePath    As String
    Dim Filespec    As String
    Dim row         As Long
    Dim SubFolder   As Variant
        
        If SubFolders Is Nothing Then Set SubFolders = New Collection
    
        FilePath = IIf(Right(Folder_Path, 1) <> "\", Folder_Path & "\", Folder_Path)
        
        On Error Resume Next
            FileName = Dir(FilePath & "*.*", vbDirectory)
            If Err <> 0 Then GoTo NextFolder
        On Error GoTo 0
        
        Do While FileName <> ""
            Filespec = FilePath & FileName
            
            On Error Resume Next            
                If (GetAttr(Filespec) And vbDirectory) = vbDirectory Then
                    If FileName <> "." And FileName <> ".." And Include_Subfolders Then SubFolders.Add Filespec
                    If row = 0 Then
                        Rng.Offset(row, 0).Font.Bold = True
                        Rng.Offset(row, 0) = FilePath
                    End If
                Else
                    row = row + 1
                    Rng.Offset(row, 1) = FileName
                End If
            On Error GoTo 0
         
            FileName = Dir()
        Loop
        
NextFolder:
        If Include_Subfolders And SubFolders.Count <> 0 Then
            SubFolder = SubFolders.Item(1)
            SubFolders.Remove 1
            Call ListFiles(SubFolder, Rng.Offset(row + 1, 0), True)
        End If
      
End Sub

Thank you. Unfortunately the new version still CTD. Run time error 29 Out of stack space.

Hello mc84excel,

I can't troubleshoot your system. You're on your own.

Originally Posted by Leith Ross

I can't troubleshoot your system. You're on your own.

nvm. I managed to adapt the function I was using. I have run it on the same folder I was testing all along and it worked fine. So it can't be the system causing the problem, I think it must have been due to using a Collection!


Code below for anyone who needs it. Very rough, I haven't tidied it up.

Public Function fnavarListFilesFoldersByRecursiveDir(ByVal strFolder As String) As Variant
    Dim avarOutput() As Variant

    If Not fnblnExistsFileFolder(strFolder) Then
        MsgBox "Start folder '" & strFolder & "' is invalid!", vbCritical, ""
        Exit Function
    End If

    ReDim avarOutput(1 To 1)
    Call RecursiveDirFilesFoldersEngine(avarOutput, strFolder)
    fnavarListFilesFoldersByRecursiveDir = avarOutput
End Function

Private Sub RecursiveDirFilesFoldersEngine(ByRef avarOutput As Variant, ByVal strCurrDir As String)
'// Returns an array of folder names
'// Credits: adapted from function by John Walkenbach

    Dim lngCntSubDirs   As Long
    Dim i               As Long
    Dim astrDirs()      As String
    Dim strItemName     As String
    Dim strFullName     As String
    Dim iavarOutputMax  As Long
    Dim blnAddToOutput  As Boolean
    Dim blnAddToSubDir  As Boolean

    strCurrDir = fnstrGetSeparatoredPath(strCurrDir)

    On Error GoTo ErrHandler

    'for all items in this folder
    strItemName = Dir(strCurrDir & "*", vbDirectory)

    Do While Len(strItemName)

        strFullName = strCurrDir & strItemName
        If (GetAttr(strFullName) And vbDirectory) = vbDirectory Then

            'CHANGE NEXT LINE IF YOU WANT FOLDERS
            blnAddToOutput = True

            'default
            blnAddToSubDir = True

            If Len(strItemName) < 3 Then
                If strItemName = "." Or strItemName = ".." Then
                    blnAddToSubDir = False
                End If
            End If

            If blnAddToSubDir Then
                'store found directories
                lngCntSubDirs = lngCntSubDirs + 1
                ReDim Preserve astrDirs(1 To lngCntSubDirs) As String
                astrDirs(lngCntSubDirs) = strFullName
            Else
                'never change the next line
                blnAddToOutput = False
            End If
        Else
            'is file
            'CHANGE NEXT LINE IF YOU WANT FILES
            blnAddToOutput = False
        End If

        If blnAddToOutput Then
            'expand output arr
            iavarOutputMax = UBound(avarOutput)
            If iavarOutputMax > 1 Then
                iavarOutputMax = iavarOutputMax + 1
            ElseIf Len(avarOutput(1)) Then
                iavarOutputMax = iavarOutputMax + 1
            Else
                iavarOutputMax = 1
            End If
            ReDim Preserve avarOutput(1 To iavarOutputMax)

            'record item
            avarOutput(iavarOutputMax) = strFullName
        End If

SkipToNextItem:
        strItemName = Dir()
    Loop

    'Process found directories
    If lngCntSubDirs > 0 Then
        For i = 1 To lngCntSubDirs
            RecursiveDirFilesFoldersEngine avarOutput, astrDirs(i)
        Next i
    End If

    On Error GoTo 0
Exit Sub

ErrHandler:
    Select Case Err.Number
    Case 53
        Resume SkipToNextItem
    Case Else
        Debug.Assert False
    End Select
End Sub

Private Function fnblnExistsFileFolder(ByVal strFullName As String) As Boolean
'/ adapted from function written by Ken Puls (www.excelguru.ca)
    If Len(strFullName) Then
        On Error Resume Next
        fnblnExistsFileFolder = Len(Dir(strFullName, 31))
        On Error GoTo 0
    End If
End Function

Private Function fnstrGetSeparatoredPath(ByRef strPath As String, Optional ByVal blnInvert As Boolean) As String
'/ ensures folder path ends in path separator (aka trailing backslash)
'/ doesn't detect garbage input, requires a Path arg
    Dim blnChange As Boolean
    Const strcPATH_SEPARATOR As String = "\"

    If Len(strPath) Then
        blnChange = ((Right$(strPath, 1) = strcPATH_SEPARATOR) = blnInvert)
        If Not blnChange Then
            fnstrGetSeparatoredPath = strPath
        ElseIf Not blnInvert Then
            'add trailing separator
            fnstrGetSeparatoredPath = strPath & strcPATH_SEPARATOR
        Else
            'remove last character
            fnstrGetSeparatoredPath = Left$(strPath, Len(strPath) - 1)
        End If
    End If
End Function