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 
        Next sf
    Loop

End Sub

Answer 2

I became motivated to provide for myself with a kind of universal function which returns a collection of folder objects plus optionally all sub-folders all in ascending order. The collection then may be used for any purpose just by looping through the collection. The function looks as follows:

Public Function Folders(Optional ByVal fo_spec As String = vbNullString, _
                        Optional ByVal fo_subfolders As Boolean = False, _
                        Optional ByRef fo_result As String) As Collection
' ----------------------------------------------------------------------------
' Returns all folders in a folder (fo_spec) - optionally including all
' sub-folders (fo_subfolders = True) - as folder objects in ascending order.
' When no folder (fo_spec) is provided a folder selection dialog request one.
' When the provided folder does not exist or no folder is selected the
' the function returns with an empty collection. The provided or selected
' folder is returned (fo_result).
' ----------------------------------------------------------------------------
    Static cll      As Collection
    Static Queue    As Collection   ' FiFo queue for folders with sub-folders
    Static Stack    As Collection   ' LiFo stack for recursive calls
    Static foStart  As Folder
    Dim aFolders()  As Variant
    Dim fl          As File
    Dim flStart     As Folder
    Dim fo1         As Folder
    Dim fo2         As Folder
    Dim fso         As New FileSystemObject
    Dim i           As Long
    Dim j           As Long
    Dim s           As String
    Dim v           As Variant

    If cll Is Nothing Then Set cll = New Collection
    If Queue Is Nothing Then Set Queue = New Collection
    If Stack Is Nothing Then Set Stack = New Collection

    If Queue.Count = 0 Then
       '~~ Provide the folder to start with - when not provided by fo_spec via a selection dialog
       If fo_spec <> vbNullString Then
           If Not fso.FolderExists(fo_spec) Then
               fo_result = fo_spec
               GoTo xt
           End If
           Set fo1 = fso.GetFolder(fo_spec)
       Else
           Application.DisplayAlerts = False
           With Application.FileDialog(msoFileDialogFolderPicker)
               .Title = "Please select the desired folder!"
               .InitialFileName = CurDir
               .AllowMultiSelect = False
               If .Show <> -1 Then GoTo xt
               Set fo1 = fso.GetFolder(.SelectedItems(1))
           End With
       End If
       Set foStart = fo1
    Else
       '~~ When recursively called (Queue.Count <> 0) take first sub-folder queued
       Set fo1 = Queue(1)
    End If

    For Each fo2 In fo1.SubFolders
       cll.Add fo2
       If fo1.SubFolders.Count <> 0 And fo_subfolders Then
           Queue.Add fo2
       End If
    Next fo2
    Stack.Add cll ' stack result in preparation for the function being called resursively

    If Queue.Count > 0 Then
       Queue.Remove 1
    End If
    If Queue.Count > 0 Then
       Folders Queue(1).Path ' recursive call for each folder with subfolders
    End If

xt: Set fso = Nothing
    If Stack.Count > 0 Then
       Set cll = Stack(Stack.Count)
       Stack.Remove Stack.Count
    End If
    If Stack.Count = 0 Then
       If cll.Count > 0 Then
           '~~ Unload cll to array, when fo_subfolders = False only those with a ParentFolder foStart
           ReDim aFolders(cll.Count - 1)
           For Each v In cll
               aFolders(i) = v
               i = i + 1
           Next v
        
           '~~ Sort array from A to Z
           For i = LBound(aFolders) To UBound(aFolders)
               For j = i + 1 To UBound(aFolders)
                   If UCase(aFolders(i)) > UCase(aFolders(j)) Then
                       s = aFolders(j)
                       aFolders(j) = aFolders(i)
                       aFolders(i) = s
                   End If
               Next j
           Next i
        
           '~~ Transfer array as folder objects to collection
           Set cll = New Collection
           For i = LBound(aFolders) To UBound(aFolders)
               Set fo1 = fso.GetFolder(aFolders(i))
               cll.Add fo1
           Next i
       End If
       Set Folders = cll
       If Not foStart Is Nothing Then fo_result = foStart.Path
   End If
   Set cll = Nothing

End Function

The function had been tested as follows:

Private Sub Folders_Test()
    Const TEST_FOLDER = "E:\Ablage\Excel VBA\DevAndTest"
     
    Dim v       As Variant
    Dim cll     As Collection
    Dim s       As String
    Dim sStart  As String
    
    Set cll = Folders("c:\XXXX", True, sStart)
    s = "1. Test: Folders in a provided non-existing folder ('" & sStart & "')"
    Debug.Print vbLf & s
    Debug.Print String(Len(s), "-")
    Debug.Assert cll.Count = 0
    
    Set cll = Folders(TEST_FOLDER, , sStart)
    s = "2. Test: Folders in the provided folder '" & sStart & "' (without sub-folders):"
    Debug.Print vbLf & s
    Debug.Print String(Len(s), "-")
    For Each v In cll
        Debug.Print v.Path
    Next v
 
    Set cll = Folders(TEST_FOLDER, True, sStart)
    s = "3. Test: Folders in the provided folder '" & sStart & "' (including sub-folders):"
    Debug.Print vbLf & s
    Debug.Print String(Len(s), "-")
    For Each v In cll
        Debug.Print v.Path
    Next v

    Set cll = Folders(, True, sStart)
    s = "4. Test: Folders in the manually selected folder '" & sStart & "' (including sub-folders):"
    Debug.Print vbLf & s
    Debug.Print String(Len(s), "-")
    For Each v In cll
        Debug.Print v.Path
    Next v
End Sub

Answer 3

@Tadas: "...but somehow it doesn't even show up as a macro and I can not run it."

Try declaring the sub as Public, e.g. Public Sub FileListingAllFolder() . Private subs and private functions do not show up in the Macros list.

Answer 4

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 5

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'.