從文件夾和子文件夾中獲取文件列表 Excel VBA

Question

我已經有一個腳本可以獲取文件夾中的文件列表，但我還需要包含子文件夾，你能幫我修改一下嗎，我試圖從這里找到的答案中編譯一些東西但失敗了。

Sub getfiles()

Dim oFSO As Object
Dim oFolder As Object
Dim oFile As Object
Dim i As Integer


Set oFSO = CreateObject("Scripting.FileSystemObject")

Set oFolder = oFSO.getfolder("C:\Users\cirklta\Desktop\excel reports")

For Each oFile In oFolder.Files

If oFile.DateLastModified > Now - 7 Then

    Cells(i + 1, 1) = oFolder.Path
    Cells(i + 1, 2) = oFile.Name
    Cells(i + 1, 3) = "RO"
    Cells(i + 1, 4) = oFile.DateLastModified

    i = i + 1
    
End If

Next oFile

Answer 1

這是一個非遞歸方法：

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 'add to collection for processing
        Next sf
    Loop

End Sub

Answer 2

你可以這樣做。

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 Scripting Runtime”的引用。

Answer 3

這是一個更簡單和更快的方法。 這應該將所有結果寫入一個文本文件，您所要做的就是打開該文件並讀取其內容。

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

Answer 4

@Tadas：“......但不知何故，它甚至沒有顯示為宏，我無法運行它。”

嘗試將 sub 聲明為 Public，例如 Public Sub FileListingAllFolder()。 私有子和私有函數不會顯示在宏列表中。

Answer 5

我變得有動力為自己提供一種通用的 function，它返回文件夾對象的集合以及可選的所有子文件夾，全部按升序排列。 然后，只需循環遍歷該集合，該集合就可以用於任何目的。 function 如下所示：

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

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