Print file names in folder to Excel Sheet in order of file creation date

Question

Hi there I have a procedure that prints file names found in a folder to an excel sheet, but I wonder if it could be modified so that it sorts the files in the folder by file Date Modified (like in the explorer) first and then prints the file names in that order to the sheet. Any help would be appreciated!

Sub HGDW_PrintFiles()
    Dim objFSO As Object
    Dim objFolder As Object
    Dim objFile As Object
    Dim i As Integer

    'Create an object of the FileSystemObject
    Set objFSO = CreateObject("Scripting.FileSystemObject")

    'Get the folder object
    Set objFolder = objFSO.Getfolder("C:\Users\bf91955\Desktop\Test\")
    i = 1

    'loops through each file in the directory and prints their names and path
    For Each objFile In objFolder.Files
        'print file name to column a
        Cells(i, 1) = objFile.Name
        i = i + 1
    Next objFile
End Sub

Answer 1

This would read it into an array and then bubble sort the array before output. The sorting here happens in the VBA array which should be faster than a sorting in the worksheet range.

Sub ReadFiles()
    Dim strFolder As String
    Dim fso As Object
    Dim fld As Object
    Dim fil As Object
    Dim arrNames() As String
    Dim arrDates() As Date
    Dim i As Long
    Dim j As Long
    Dim n As Long
    Dim strTmp As String
    Dim dtmTmp As Date

    Set fso = CreateObject("Scripting.FileSystemObject")
    ' Modify as needed
    strFolder = "C:\"
    Set fld = fso.GetFolder(strFolder)

    ' Set up arrays
    n = fld.Files.Count
    ReDim arrNames(1 To n)
    ReDim arrDates(1 To n)

    ' Fill arrays
    For Each fil In fld.Files
        i = i + 1
        arrNames(i) = fil.Name
        arrDates(i) = fil.DateLastModified
    Next fil

    ' Bubble sort descending on date
    For i = 1 To n - 1
        For j = i + 1 To n
            If arrDates(i) < arrDates(j) Then 'to sort ascending change < to >
                dtmTmp = arrDates(i)
                arrDates(i) = arrDates(j)
                arrDates(j) = dtmTmp
                strTmp = arrNames(i)
                arrNames(i) = arrNames(j)
                arrNames(j) = strTmp
            End If
        Next j
    Next i

    ' Do something with the arrays, e.g.
    For i = 1 To n
        Debug.Print arrNames(i)
    Next i
End Sub

Answer 2

Sub HGDW_PrintFiles()
Dim objFSO As Object
Dim objFolder As Object
Dim objFile As Object
Dim i As Integer


'Create an object of the FileSystemObject
Set objFSO = CreateObject("Scripting.FileSystemObject")

'Get the folder object
Set objFolder = objFSO.Getfolder("C:\Users\bf91955\Desktop\Test\")
i = 1

'loops through each file in the directory and prints their names and path
For Each objFile In objFolder.Files
    'print file name to column a, column b is date last modified
     Cells(i, 1) = objFile.Name
     Cells(i, 2) = objFile.DateLastModified

    i = i + 1
Next objFile

Range("A1").Select
Selection.End(xlDown).Select

'sort most recent
ActiveWorkbook.Worksheets("Hoja1").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Hoja1").Sort.SortFields.Add Key:=Range("B1"), _
    SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:= _
    xlSortTextAsNumbers
With ActiveWorkbook.Worksheets(ActiveSheet.Name).Sort
    .SetRange Range("A1:B" & ActiveCell.Row)
    .Header = xlNo
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
    End With
End Sub

Answer 3

The sample file from the link below will do what you want, and a whole lot more. Just click the button named 'Download Now' to get started.

http://learnexcelmacro.com/wp/2011/11/how-to-get-list-of-all-files-in-a-folder-and-sub-folders/

'**********************************************************************
'*                                                                    *
'* Written by Vish Mishra - http://www.LearnExcelMacro.Com            *
'* You can list down all the files with properties at once place      *
'* Just by one click using this File Manager                          *
'*                                                                    *
'**********************************************************************

Public fPath As String
Public IsSubFolder As Boolean
Public iRow As Long
Public FSO As Scripting.FileSystemObject
Public SourceFolder As Scripting.folder, SubFolder As Scripting.folder
Public FileItem As Scripting.File
Public IsFileTypeExists As Boolean



Public Sub ListFilesInFolder(SourceFolder As Scripting.folder, IncludeSubfolders As Boolean)


    On Error Resume Next
    For Each FileItem In SourceFolder.Files


' display file properties
        Cells(iRow, 2).Formula = iRow - 13
        Cells(iRow, 3).Formula = FileItem.Name
        Cells(iRow, 4).Formula = FileItem.Path
        Cells(iRow, 5).Formula = Int(FileItem.Size / 1024)
        Cells(iRow, 6).Formula = FileItem.Type
        Cells(iRow, 7).Formula = FileItem.DateLastModified
        Cells(iRow, 8).Select
        Selection.Hyperlinks.Add Anchor:=Selection, Address:= _
        FileItem.Path, TextToDisplay:="Click Here to Open"

'Cells(iRow, 8).Formula = "=HYPERLINK(""" & FileItem.Path & """,""" & "Click Here to Open" & """)"

        iRow = iRow + 1 ' next row number
        Next FileItem

        If IncludeSubfolders Then
            For Each SubFolder In SourceFolder.SubFolders
                ListFilesInFolder SubFolder, True
                Next SubFolder
            End If

            Set FileItem = Nothing
            Set SourceFolder = Nothing
            Set FSO = Nothing



        End Sub




        Public Sub ListFilesInFolderXtn(SourceFolder As Scripting.folder, IncludeSubfolders As Boolean)


            On Error Resume Next
            Dim FileArray As Variant

            FileArray = Get_File_Type_Array

            For Each FileItem In SourceFolder.Files

                Call ReturnFileType(FileItem.Type, FileArray)

                If IsFileTypeExists = True Then

                    Cells(iRow, 2).Formula = iRow - 13
                    Cells(iRow, 3).Formula = FileItem.Name
                    Cells(iRow, 4).Formula = FileItem.Path
                    Cells(iRow, 5).Formula = Int(FileItem.Size / 1024)
                    Cells(iRow, 6).Formula = FileItem.Type
                    Cells(iRow, 7).Formula = FileItem.DateLastModified

                    Cells(iRow, 8).Select
                    Selection.Hyperlinks.Add Anchor:=Selection, Address:= _
                    FileItem.Path, TextToDisplay:="Click Here to Open"

'Cells(iRow, 8).Formula = "=HYPERLINK(""" & FileItem.Path & """,""" & "Click Here to Open" & """)"

                    iRow = iRow + 1 ' next row number

                End If
                Next FileItem

                If IncludeSubfolders Then
                    For Each SubFolder In SourceFolder.SubFolders
                        ListFilesInFolderXtn SubFolder, True
                        Next SubFolder
                    End If

                    Set FileItem = Nothing
                    Set SourceFolder = Nothing
                    Set FSO = Nothing



                End Sub



                Sub ResultSorting(xlSortOrder As String, sKey1 As String, sKey2 As String, sKey3 As String)
                    Range("C13").Select
                    Range(Selection, Selection.End(xlDown)).Select
                    Range(Selection, Selection.End(xlToRight)).Select

                    Selection.Sort Key1:=Range(sKey1), Order1:=xlSortOrder, Key2:=Range(sKey2 _
                    ), Order2:=xlAscending, Key3:=Range(sKey3), Order3:=xlSortOrder, Header _
                    :=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom _
                    , DataOption1:=xlSortNormal, DataOption2:=xlSortNormal, DataOption3:= _
                    xlSortNormal

                    Range("B14").Select
                End Sub


                Sub ClearResult()
                    If Range("B14") <> "" Then

                        Range("B14").Select
                        Range(Selection, Selection.End(xlDown)).Select
                        Range(Selection, Selection.End(xlToRight)).Select
                        Range(Selection.Address).ClearContents
                    End If
                End Sub


                Public Function Get_File_Type_Array() As Variant

                    Dim i, j, TotalSelected As Integer
                    Dim arrList() As String
                    TotalSelected = 0
                    For i = 0 To Sheet1.ListBoxFileTypes.ListCount - 1
                        If Sheet1.ListBoxFileTypes.Selected(i) = True Then
                            TotalSelected = TotalSelected + 1
                        End If
                    Next

                    ReDim arrList(0 To TotalSelected - 1) As String
                    j = 0
                    i = 0
                    For i = 0 To Sheet1.ListBoxFileTypes.ListCount - 1

                        If Sheet1.ListBoxFileTypes.Selected(i) = True Then
                            arrList(j) = Left(Sheet1.ListBoxFileTypes.List(i), InStr(1, Sheet1.ListBoxFileTypes.List(i), "(") - 1)
                            j = j + 1
                        End If

                    Next

                    Get_File_Type_Array = arrList

                End Function


                Public Function ReturnFileType(fileType As String, FileArray As Variant) As Boolean

                    Dim i As Integer

                    IsFileTypeExists = False

                    For i = 1 To UBound(FileArray) + 1

                        If FileArray(i - 1) = fileType Then

                            IsFileTypeExists = True
                            Exit For

                        Else
                            IsFileTypeExists = False
                        End If

                    Next

                End Function



                Sub textfile(iSeperator As String)

                    Dim iRow, iCol
                    Dim iLine, f




                    ThisWorkbook.Activate
                    Range("B13").Select
                    TotalRowNumber = Range(Selection, Selection.End(xlDown)).Count - 12

                    If iSeperator <> "vbTab" Then

                        Open ThisWorkbook.Path & "\File1.txt" For Output As #1
                        Print #1, ""
                        Close #1

                        Open ThisWorkbook.Path & "\File1.txt" For Append As #1
                        For iRow = 13 To TotalRowNumber

                            iLine = ""

                            For iCol = 2 To 7

                                iLine = iLine & iSeperator & Cells(iRow, iCol).Value
                            Next
                            Print #1, iLine
                        Next
                        Close #1


                    Else

                        Open ThisWorkbook.Path & "\File1.txt" For Output As #1
                        Print #1, ""
                        Close #1

                        Open ThisWorkbook.Path & "\File1.txt" For Append As #1
                        For iRow = 13 To TotalRowNumber

                            iLine = ""

                            For iCol = 2 To 7

                                iLine = iLine & vbTab & Cells(iRow, iCol).Value
                            Next
                            Print #1, iLine
                        Next
                        Close #1

                    End If



                    f = Shell("C:\WINDOWS\notepad.exe " & ThisWorkbook.Path & "\File1.txt", vbMaximizedFocus)

'MsgBox "Your File is saved" & ThisWorkbook.Path & "\File1.txt"

                End Sub





                Sub Export_to_excel()
                    On Error GoTo err



                    Dim xlApp As New Excel.Application
                    Dim xlWB As New Workbook

                    Set xlWB = xlApp.Workbooks.Add
'xlWB.Add
                    xlApp.Visible = False


                    ThisWorkbook.Activate
                    Range("B13").Select
                    Range(Selection, Selection.End(xlDown)).Select
                    Range(Selection, Selection.End(xlToRight)).Select

                    Selection.Copy

                    xlApp.Visible = True
                    xlWB.Activate
                    xlWB.Sheets("Sheet1").Select
                    xlWB.Sheets("Sheet1").Range("B2").PasteSpecial Paste:=xlPasteValues
                    xlWB.Sheets("Sheet1").Cells.Select
                    xlWB.Sheets("Sheet1").Cells.EntireColumn.AutoFit
                    xlWB.Sheets("Sheet1").Range("B2").Select
                    Exit Sub
err:
                    MsgBox ("Error Occured while exporting. Try again")

                End Sub