下面是一个非递归方法：

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

这里有一个更简单更快速的方法，它会把所有的结果写入一个文本文件，你所要做的就是打开这个文件并读取它的内容。

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

你可以这样做。

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

在“工具”下，设置对“Microsoft脚本运行时”的引用。

@Tadas：“......但不知怎么的，它甚至没有显示为宏，我无法运行它。”
尝试将子函数声明为公共，例如公共子函数FileListingAllFolder（）。私有子函数和私有函数不会显示在宏列表中。

我开始为自己提供一种通用函数，它返回一个文件夹对象集合，并可选地返回所有子文件夹，所有子文件夹都按升序排列。然后，只需循环遍历该集合，就可以将该集合用于任何目的。该函数如下所示：

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

已对该功能进行了如下测试：

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