Question

您好，我有一个程序可以将文件夹中找到的文件名打印到Excel工作表，但我想知道是否可以对其进行修改，以便按文件Date Modified对文件夹中的文件进行排序（如首先，然后按顺序将文件名打印到工作表。任何帮助，将不胜感激！

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

这会将其读入数组，然后在输出之前对数组进行冒泡排序。这里的排序发生在VBA数组中，它应该比工作表范围内的排序更快。

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

以下链接中的示例文件将执行您想要的操作，以及更多内容。只需单击名为“立即下载”的按钮即可开始使用。

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

按文件创建日期的顺序将文件夹中的文件名打印到Excel Sheet

3 个答案: