Need count of all files under folder with modification date

[rawr19911]

needing a micro that will count files under EVERY folder and give these fields so if I search lets say my documents put in C:\Users\Name\Documents then it will list all files under this location and all files under different folders in this location as well. so everything

 

[smozgur]

Using the Scripting.FileSystemObject library in the following code: Copy and paste it into a new standard module, change the strPath variable, and run the doListFiles() sub-procedure. The code is using late-binding (no need to reference the library). However, if you want it work a bit faster then select the library in Tools->References, and change the variable declaration as it was commented in the code (also Set fso line)
Comments are in the code.

Option Explicit

Sub doListFiles()
Dim strPath As String
Dim sht As Worksheet
Dim rng As Range
Dim Path As String
Dim fso As Object 'FileSystemObject ' If early binding
Dim fld As Object 'Folder           ' If early binding
Dim fil As Object 'File             ' If early binding

    ' Starting path
    strPath = "C:\Users\myuser\Downloads"

    ' Create a new worksheet
    Set sht = ActiveWorkbook.Worksheets.Add
    ' Set up column headers
    Set rng = sht.Cells(1, 1)
    rng.Resize(, 5).Value = Array("FileName", "FileLocation", "Extension", "CreationDate", "LastAccessDate", "LastModficationDate")

    ' New FileSystemObject
    Set fso = CreateObject("Scripting.FileSystemObject") 'New FileSystemObject  ' If early binding
    ' Starting folder object
    Set fld = fso.GetFolder(strPath)
    ' Call the sub procedure for the starting path
    getFilesFromFolder fld, rng
    ' Done
    MsgBox "Done", vbOKOnly + vbInformation, "Done"
End Sub

Private Sub getFilesFromFolder(fld As Object, rng As Range)
Dim subfld As Object ' Folder ' If early binding
Dim fil As Object ' File ' If early binding
    ' In case the file or folder is not accessible
    On Error GoTo ErrHandler
    ' Loop through files in the given folder
    For Each fil In fld.Files
        ' To allow interrupting code execution just in case - Ctrl + Break
        DoEvents
        ' Next empty data row
        Set rng = rng.Offset(1)
        ' Fill in the required values
        With rng
            .Cells(, 1).Value = fil.Name
            .Cells(, 2).Value = fld.Path
            .Cells(, 3).Value = Right(fil.Name, Len(fil.Name) - InStrRev(fil.Name, "."))
            .Cells(, 4).Value = fil.DateCreated
            .Cells(, 5).Value = fil.DateLastAccessed
            .Cells(, 6).Value = fil.DateLastModified
        End With
    Next fil
    
    ' Loop through sub folders in the given folder
    For Each subfld In fld.SubFolders
        ' Recursive call to itself
        getFilesFromFolder subfld, rng
    Next subfld
ErrHandler:
    ' If error then the folder is not accessible
    ' Simply ignore
End Sub

 

[rawr19911]

Using the Scripting.FileSystemObject library in the following code: Copy and paste it into a new standard module, change the strPath variable, and run the doListFiles() sub-procedure. The code is using late-binding (no need to reference the library). However, if you want it work a bit faster then select the library in Tools->References, and change the variable declaration as it was commented in the code (also Set fso line)
Comments are in the code.

Option Explicit

Sub doListFiles()
Dim strPath As String
Dim sht As Worksheet
Dim rng As Range
Dim Path As String
Dim fso As Object 'FileSystemObject ' If early binding
Dim fld As Object 'Folder           ' If early binding
Dim fil As Object 'File             ' If early binding

    ' Starting path
    strPath = "C:\Users\myuser\Downloads"

    ' Create a new worksheet
    Set sht = ActiveWorkbook.Worksheets.Add
    ' Set up column headers
    Set rng = sht.Cells(1, 1)
    rng.Resize(, 5).Value = Array("FileName", "FileLocation", "Extension", "CreationDate", "LastAccessDate", "LastModficationDate")

    ' New FileSystemObject
    Set fso = CreateObject("Scripting.FileSystemObject") 'New FileSystemObject  ' If early binding
    ' Starting folder object
    Set fld = fso.GetFolder(strPath)
    ' Call the sub procedure for the starting path
    getFilesFromFolder fld, rng
    ' Done
    MsgBox "Done", vbOKOnly + vbInformation, "Done"
End Sub

Private Sub getFilesFromFolder(fld As Object, rng As Range)
Dim subfld As Object ' Folder ' If early binding
Dim fil As Object ' File ' If early binding
    ' In case the file or folder is not accessible
    On Error GoTo ErrHandler
    ' Loop through files in the given folder
    For Each fil In fld.Files
        ' To allow interrupting code execution just in case - Ctrl + Break
        DoEvents
        ' Next empty data row
        Set rng = rng.Offset(1)
        ' Fill in the required values
        With rng
            .Cells(, 1).Value = fil.Name
            .Cells(, 2).Value = fld.Path
            .Cells(, 3).Value = Right(fil.Name, Len(fil.Name) - InStrRev(fil.Name, "."))
            .Cells(, 4).Value = fil.DateCreated
            .Cells(, 5).Value = fil.DateLastAccessed
            .Cells(, 6).Value = fil.DateLastModified
        End With
    Next fil
   
    ' Loop through sub folders in the given folder
    For Each subfld In fld.SubFolders
        ' Recursive call to itself
        getFilesFromFolder subfld, rng
    Next subfld
ErrHandler:
    ' If error then the folder is not accessible
    ' Simply ignore
End Sub

Thank you this works perfect you are amazing!

 

[smozgur]

Thank you this works perfect you are amazing!

You’re welcome. Glad to hear it helps.