Files within Multiple SubFolders and SubFolders Within It

Hey Guys,

In need of some assistance. Basically, my objective is to get the list of files inside a particular directory. Directory includes many subfolders and inside those we again have 'n' number of folders. Am able to successfully get the file list if they in the parent or within 1-level subfolders. I need to get the list of files from 'n' number of levels of directory.

Sub ListFilesFromFolderAndSubFolders()
'
' http://vbaexpress.com/forum/showthread.php?t=10829&page=2
'
    Dim f As Object, fso As Object, flder As Object
    Dim extn As String, IsXLFile As Boolean
    Dim folder As String
    Dim wb As Workbook, ws As Worksheet
    Dim TotalFiles As Long, TotalFolders As Long
    
    Set wb = ActiveWorkbook
    Set ws = ActiveSheet
    Set fso = CreateObject("Scripting.FileSystemObject")
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Show
        If .SelectedItems.Count = 0 Then
            End
        End If
        folder = .SelectedItems(1) 'vPath
    End With    
    
    For Each f In fso.GetFolder(folder).Files
        extn = Right(f.Name, Len(f.Name) - InStrRev(f.Name, "."))
        Select Case extn
            Case "xlsx": IsXLFile = True
            Case "xlsb": IsXLFile = True
            Case "xlsm": IsXLFile = True
            Case "xls": IsXLFile = True
            Case Else: IsXLFile = False
        End Select
        If IsXLFile = True And CDate(f.DateLastModified) >= CDate("8/11/2013 0:00:00") Then
            ws.Range("A" & ws.Rows.Count).End(xlUp).Offset(1, 0) = f.Path
        End If
    Next
    For Each flder In fso.GetFolder(folder).SubFolders
        For Each f In fso.GetFolder(flder.Path).Files
            extn = Right(f.Name, Len(f.Name) - InStrRev(f.Name, "."))
            Select Case extn
                Case "xlsx": IsXLFile = True
                Case "xlsb": IsXLFile = True
                Case "xlsm": IsXLFile = True
                Case "xls": IsXLFile = True
                Case Else: IsXLFile = False
            End Select
            'ws.Range("A" & ws.Rows.Count).End(xlUp).Offset(1, 0) = f.Name
            'ws.Range("C" & ws.Rows.Count).End(xlUp).Offset(1, 0) = Right(f.Name, Len(f.Name) - InStrRev(f.Name, "."))
            'ws.Range("C" & ws.Rows.Count).End(xlUp).Offset(1, 0) = CDate(f.DateLastModified)
            If IsXLFile = True And CDate(f.DateLastModified) >= CDate("8/11/2013 0:00:00") Then
                ws.Range("A" & ws.Rows.Count).End(xlUp).Offset(1, 0) = f.Path
            End If
        Next
    Next
End Sub

Thing is, I don't have pre-defined knowledge of how many levels it could be as it is defined by the users. With my above code, I know I'll have to repeat the loop for SubFolders and Files in them to the times the levels available. So I just need to know how many times, I'll have to loop or so..

Am very much fond of new thoughts and suggestions if something better hit your heads.. Open for thoughts!

See if this helps...

Add a filespec ('c:\temp\*.xl*' for example) in A1 of a blank sheet. All matching files will be returned in Col B and run the code.

It does open another blank window on screen - unfortunately this cannot be hidden, but it should disappear fairly quickly depending on how many files are found.

Sub x()
     
    Dim str As String
    Dim Lines() As String
    
'    On Error GoTo ErrHandler
         
     '// c:\temp\test\*.* = Filespec to use for DIR. Parameters are:
     '// /o = Sort
     '// - = Reverse
     '// d = Date
    str = CreateObject("WScript.Shell").EXEC("cmd /c dir " & Range("A1").Value & " /s /b /o-d").stdout.readall
     
     '// Split the returned string into the Array LINES
     '// Delimiter is the Carriage Return/Line Feed pair (vbCrLf)
    Lines = Split(str, vbCrLf)
     
     '// Make sure some file names were returned
    If UBound(Lines) > 4 Then
        Range("B1").Resize(UBound(Lines)).Value = WorksheetFunction.Transpose(Lines)
    End If
    
End Sub

If you think this is suitable, it would be easy to split out/determine the actual information you need.

Hey Cytop,

Thanks much for your response. Idea was good to get the count for the folders but really that CMD window is one annoying thing that needs to be closed everytime... :p

I've worked out on my codes and am able to get my answers. I've used recursive method to get it work. But its running a bit slow as its calling the function again and again, plus, considering the amount of search its making in the disk. (I must say, I hate loops!! )

Following is my updated code.

Sub ListFilesFromFolderAndSubFolders()
'
' http://vbaexpress.com/forum/showthread.php?t=10829&page=2
'
    Dim f As Object, fso As Object, flder As Object
    Dim extn As String, IsXLFile As Boolean
    Dim folder As String
    Dim wb As Workbook, ws As Worksheet
    Dim TotalFiles As Long, TotalFolders As Long
    Dim SinceDate As Date
    
    Set wb = ActiveWorkbook
    Set ws = ActiveSheet
    Set fso = CreateObject("Scripting.FileSystemObject")
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Show
        If .SelectedItems.Count = 0 Then
            'MsgBox "Cancel Selected"
            End
        End If
        folder = .SelectedItems(1) 'vPath
    End With
    'TotalFiles = 0
    'TotalFolders = 0
    
    Set flder = fso.GetFolder(folder)
    SinceDate = "8/11/2013 0:00:00"
    BoostMacroPerformance True, True
    RecursiveSearch flder, ws, SinceDate
    BoostMacroPerformance False, True
    Set flder = Nothing
    Set fso = Nothing
End Sub


Private Sub RecursiveSearch(fld As Object, ws As Worksheet, SinceDate As Date)
    Dim fold As Object
    Dim fl As Object
    Dim extn As String, IsXLFile As Boolean

    For Each fold In fld.SubFolders
        RecursiveSearch fold, ws, SinceDate
    Next
    For Each fl In fld.Files
        extn = Right(fl.Name, Len(fl.Name) - InStrRev(fl.Name, "."))
        Select Case extn
            Case "xlsx": IsXLFile = True
            Case "xlsb": IsXLFile = True
            Case "xlsm": IsXLFile = True
            Case "xls": IsXLFile = True
            Case Else: IsXLFile = False
        End Select
        If IsXLFile = True And CDate(fl.DateLastModified) >= CDate(SinceDate) Then
            'ws.Range("E" & ws.Range("D" & ws.Rows.Count).End(xlUp).Row) = "Yes"
            ws.Range("A" & ws.Rows.Count).End(xlUp).Offset(1, 0) = fl.Path
        End If
    Next
End Sub

P.S. BoostMacroPerformance is a method that I use to set certain settings of the application (ScreenUpdating, EnableEvents, Calculation and DisplayAlerts) to boost the speed of macro to an extent.

Only thing that am not able to get the property - "Last Saved By" of the file and any alternate ways to boost up the speed by avoiding loop if we can..

It is buddy. Actually, it seems that it comes with Windows 7 as I haven't seen this property in Windows XP or before. Its an extended property under Origin section. Can't find a way to get to it..

http://s23.postimg.org/j5rxjftu3/Last_Saved_By.jpg

Hey Guys,

I made a little research, and have found that the property actually belongs to BuiltinDocumentProperties of the workbook and can be made in use when file is open. Any ways to call use this property without opening the file..? Below code works and gets me the detail

Sub Test()
    MsgBox Workbooks.Open("<path>\Sample.xlsx").BuiltinDocumentProperties("Last Author")
End Sub

Alright, I've got the solution to my issue. It involves usage of an extra DLL called "DSOFile" which I believe will be working on only with Office version - 2007 onwards. Am not sure about whether if it works for 2003 or before.

Sub Test()
    Dim objFile As Object
    Set objFile = CreateObject("DSOFile.OleDocumentProperties")
    objFile.Open ("C:\Test\Assignment.xlsx")
    MsgBox "Last saved by: " & objFile.SummaryProperties.LastSavedBy
    Exit Sub
End Sub

Here is the link from where I got my solution.