Get File list from folders and subfolders Excel VBA

Question

I already have a script that gets list of file in a folder but I need to include subfolders as well, can you please help me modify this, I have tried to compile something from the answers found here but failed.

Sub getfiles()

Dim oFSO As Object
Dim oFolder As Object
Dim oFile As Object
Dim i As Integer


Set oFSO = CreateObject("Scripting.FileSystemObject")

Set oFolder = oFSO.getfolder("C:\Users\cirklta\Desktop\excel reports")

For Each oFile In oFolder.Files

If oFile.DateLastModified > Now - 7 Then

    Cells(i + 1, 1) = oFolder.Path
    Cells(i + 1, 2) = oFile.Name
    Cells(i + 1, 3) = "RO"
    Cells(i + 1, 4) = oFile.DateLastModified

    i = i + 1
    
End If

Next oFile

Answer 1

Here's a non-recursive method:

Sub getfiles()

    Dim oFSO As Object
    Dim oFolder As Object
    Dim oFile As Object, sf
    Dim i As Integer, colFolders As New Collection, ws As Worksheet
    
    Set ws = ActiveSheet
    Set oFSO = CreateObject("Scripting.FileSystemObject")
    Set oFolder = oFSO.getfolder("C:\Users\cirklta\Desktop\excel") 
    
    colFolders.Add oFolder          'start with this folder
    
    Do While colFolders.Count > 0      'process all folders
        Set oFolder = colFolders(1)    'get a folder to process
        colFolders.Remove 1            'remove item at index 1
    
        For Each oFile In oFolder.Files
            If oFile.DateLastModified > Now - 7 Then
                ws.Cells(i + 1, 1) = oFolder.Path
                ws.Cells(i + 1, 2) = oFile.Name
                ws.Cells(i + 1, 3) = "RO"
                ws.Cells(i + 1, 4) = oFile.DateLastModified
                i = i + 1
            End If
        Next oFile

        'add any subfolders to the collection for processing
        For Each sf In oFolder.subfolders
            colFolders.Add sf 'add to collection for processing
        Next sf
    Loop

End Sub

Answer 2

Here's a much simpler and faster method. This should write all the results in a text file and all you have to do is to open that file and read its contents.

Sub List_All_Files_And_SubFolders()
    PID = Shell("cmd /k dir c:\test /s /b > c:\test\all_files.txt", vbHide)
    While IsFileInUse() = True: DoEvents: Wend
End Sub


Function IsFileInUse()
On Error GoTo Error_Handeling
    
    IsFileInUse = True
    Name "c:\test\all_files.txt" As "c:\test\all_files1.txt"
    Name "c:\test\all_files1.txt" As "c:\test\all_files.txt"
    IsFileInUse = False
    
Error_Handeling:
    If Err.Description = "Path/File access error" Then IsFileInUse = True: Exit Function

End Function

Answer 3

You can do it this way.

Sub FileListingAllFolder()
    
' Open folder selection
' Open folder selection

With Application.FileDialog(msoFileDialogFolderPicker)
    .Title = "Select a Folder"
    .AllowMultiSelect = False
    If .Show <> -1 Then GoTo NextCode
    pPath = .SelectedItems(1)
        If Right(pPath, 1) <> "\" Then
            pPath = pPath & "\"
        End If
End With


Application.WindowState = xlMinimized
Application.ScreenUpdating = False

    Workbooks.Add ' create a new workbook for the file list
    ' add headers
    ActiveSheet.Name = "ListOfFiles"
    With Range("A2")
        .Formula = "Folder contents:"
        .Font.Bold = True
        .Font.Size = 12
    End With
    Range("A3").Formula = "File Name:"
    Range("B3").Formula = "File Size:"
    Range("C3").Formula = "File Type:"
    Range("D3").Formula = "Date Created:"
    Range("E3").Formula = "Date Last Accessed:"
    Range("F3").Formula = "Date Last Modified:"
    Range("A3:F3").Font.Bold = True

    Worksheets("ListOfFiles").Range("A1").Value = pPath
    
        Range("A1").Select
        With Selection.Interior
            .Pattern = xlSolid
            .PatternColorIndex = xlAutomatic
            .Color = 65535
            .TintAndShade = 0
            .PatternTintAndShade = 0
        End With
        With Selection.Font
            .Color = -16776961
            .TintAndShade = 0
        End With
        Selection.Font.Bold = True
    
    ListFilesInFolder Worksheets("ListOfFiles").Range("A1").Value, True
    ' list all files included subfolders

    Range("A3").Select
    
    Lastrow = Range("A1048576").End(xlUp).Row
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlDown)).Select

    ActiveWorkbook.Worksheets("ListOfFiles").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("ListOfFiles").Sort.SortFields.Add Key:=Range( _
        "B4:B" & Lastrow), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:= _
        xlSortNormal
    With ActiveWorkbook.Worksheets("ListOfFiles").Sort
        .SetRange Range("A3:F" & Lastrow)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    Range("A1").Select
    
Cells.Select
Cells.EntireColumn.AutoFit
Columns("A:A").Select
Selection.ColumnWidth = 100
Range("A1").Select
   
NextCode:
MsgBox "No files Selected!!"

End Sub

Sub ListFilesInFolder(SourceFolderName As String, IncludeSubfolders As Boolean)
' lists information about the files in SourceFolder
Dim FSO As Scripting.FileSystemObject
Dim SourceFolder As Scripting.Folder, SubFolder As Scripting.Folder
Dim FileItem As Scripting.File
Dim r As Long
    Set FSO = New Scripting.FileSystemObject
    Set SourceFolder = FSO.GetFolder(SourceFolderName)
    r = Range("A1048576").End(xlUp).Row + 1
    For Each FileItem In SourceFolder.Files
        ' display file properties
        Cells(r, 1).Formula = FileItem.Path & FileItem.Name
        Cells(r, 2).Formula = (FileItem.Size / 1048576)
            Cells(r, 2).Value = Format(Cells(r, 2).Value, "##.##") & " MB"
        Cells(r, 3).Formula = FileItem.Type
        Cells(r, 4).Formula = FileItem.DateCreated
        Cells(r, 5).Formula = FileItem.DateLastAccessed
        Cells(r, 6).Formula = FileItem.DateLastModified
        ' use file methods (not proper in this example)

        r = r + 1 ' next row number
    Next FileItem
    If IncludeSubfolders Then
        For Each SubFolder In SourceFolder.SubFolders
            ListFilesInFolder SubFolder.Path, True
        Next SubFolder
    End If
    Columns("A:F").AutoFit
    Set FileItem = Nothing
    Set SourceFolder = Nothing
    Set FSO = Nothing
    ActiveWorkbook.Saved = True
End Sub

Under Tools, set a reference to 'Microsoft Scripting Runtime'.