Loop through all subfolders and files under a fold

Question

This question already has answers here:

Get list of sub-directories in VBA (4 answers)

Closed 5 years ago.

I have searched the forum, and found similar questions that got answered, but I am really a beginner in VBA.

I want to copy the name, path, and last modified date information to an Excel spreadsheet.

The code in the following two threads can help me add the name, path and last modified date information of a certain folder to Spreadsheet. The only thing I need to do is to add a loop that searches files under subfolders. I tried to, but it was not successful.

Can anyone help me add a loop of the files in the subfolders based on the code below?

Getting file last modified date (explorer value not cmd value)

Excel VBA using FileSystemObject to list file last date modified

Sub ListFilesinFolderNew()

    Dim FSO As Scripting.FileSystemObject
    Dim SourceFolder As Scripting.Folder
    Dim FileItem As Scripting.File
    Dim fsoFol As Scripting.Folder

    SourceFolderName = "C:\Users\lc\Downloads"

    Set FSO = New Scripting.FileSystemObject
    Set SourceFolder = FSO.GetFolder(SourceFolderName)

    Range("A1:C1") = Array("file", "path", "Date Last Modified")

    i = 2

    For Each fsoFol In SourceFolder.SubFolders

    For Each FileItem In fsoFol.Files
        Cells(i, 1) = FileItem.Name
        Cells(i, 2) = FileItem
        Cells(i, 3) = FileItem.DateLastModified
        i = i + 1
    Next FileItem

    Next fsoFol

    Set FSO = Nothing

End Sub

Thank you.

Answer 1

In order to list all files in a folder and its subfolders, i would suggest seperating the listing logic into a seperate Sub and calling it recursively.

Something like this

Sub ListFilesinFolderNew()
    Dim FSO As Scripting.FileSystemObject
    Dim ws As Worksheet
    Dim cl As Range
    Dim SourceFolderName As String

    SourceFolderName = "C:\Users\lc\Downloads"

    Set FSO = New Scripting.FileSystemObject

    Set ws = ActiveSheet  '<-- adjust to suit your needs

    ws.Range("A1:C1") = Array("file", "path", "Date Last Modified")
    Set cl = ws.Cells(2, 1)

    ListFolders cl, FSO.GetFolder(SourceFolderName)

    Set FSO = Nothing
End Sub

Sub ListFolders(rng As Range, Fol As Scripting.Folder)
    Dim SubFol  As Scripting.Folder
    Dim FileItem As Scripting.File

    ' List Files
    For Each FileItem In Fol.Files
        rng.Cells(1, 1) = FileItem.Name
        rng.Cells(1, 2) = FileItem.ParentFolder.Path
        rng.Cells(1, 3) = FileItem.DateLastModified
        Set rng = rng.Offset(1, 0)
    Next

    ' Proces subfolders
    For Each SubFol In Fol.SubFolders
        ListFolders rng, SubFol
    Next
End Sub

Alternate method using Dir

Sub ListFilesinFolderNew2()
    Dim Path As String
    Dim fl As String
    Dim ws As Worksheet
    Dim cl As Range

    Set ws = ActiveSheet

    Path = "C:\Users\lc\Downloads"
    ws.Range("A1:C1") = Array("file", "path", "Date Last Modified")
    Set cl = ws.Cells(2, 1)

    ListFolder cl, Path, "*.*"
End Sub


Sub ListFolder(rng As Range, Path As String, Patt As String)
    Dim fl As String
    Dim sf As Collection
    Dim v As Variant

    If Right$(Path, 1) <> "\" Then Path = Path & "\"
    fl = Dir(Path & Patt)
    Do While fl <> vbNullString
        rng.Cells(1, 1) = fl
        rng.Cells(1, 2) = Path
        rng.Cells(1, 3) = FileDateTime(Path & fl)
        Set rng = rng.Offset(1, 0)

        fl = Dir()
    Loop
    Set sf = New Collection
    fl = Dir(Path, vbDirectory)
    Do While fl <> vbNullString
        If fl <> "." And fl <> ".." Then
            If (GetAttr(Path & fl) And vbDirectory) <> 0 Then
                sf.Add Path & fl
            End If
        End If
        fl = Dir()
    Loop
    For Each v In sf
        rng.Cells(1, 2) = Path
        Set rng = rng.Offset(1, 0)
        ListFolder rng, CStr(v), Patt
    Next
End Sub

Answer 2

Ok try this to get the files on the folder and sub folders:

Dim donewithparent As Boolean
For Each fsoFol In SourceFolder.SubFolders
    If Not donewithparent Then
        For Each FileItem In fsoFol.ParentFolder.Files
            Cells(i, 1) = FileItem.Name
            Cells(i, 2) = FileItem
            Cells(i, 3) = FileItem.DateLastModified
            i = i + 1
        Next
    End If
    donewithparent = True        
    For Each FileItem In fsoFOL.Files
        Cells(i, 1) = FileItem.Name
        Cells(i, 2) = FileItem
        Cells(i, 3) = FileItem.DateLastModified
        i = i + 1
    Next FileItem
Next fsoFol

Or you can do a separate loop for it before you loop on the subfolders.
Just utilize the available properties like ParentFolder.
To check if there are still sub folders undet it, you can use:

If fsoFol.Subfolders.Count > 0 Then
    '~~> add another loop here
End If

Not really ideal but should work. HTH.