尝试遍历子文件夹中的子文件夹和文件

Question

我想使用VBA访问一个文件夹，并遍历所有子文件夹中的所有Excel文件。更具体地说，我想从每个文件中的特定单元格收集数据，并将数据转储到我的活动工作簿中。我认为应该很容易写出来，但到目前为止我还没有成功。我尝试了一些方法来循环遍历我在网上找到的子文件夹，但是他们没有帮助。

这是我想要实现的目标的视觉概念：

Sub example()
'Find a way to enter file path
'Find a way to loop through subfolders
'Find a way to loop through excel files and refer to current file below
x = 2
Workbooks(Loop Test.xlsm).Worksheets("Sheet1").Cells(x,1) = 'current file in loop range A1
Workbooks(Loop Test.xlsm).Worksheets("Sheet1").Cells(x,2) = 'current file in loop range A2
' etc.
x = x + 1
' next file
End Sub

Answer 1

编写函数以返回文件列表将使测试更容易。

测试

Sub TestGetFileList()
    Dim f As Variant, fileList As Object
    Set fileList = getFileList("C:\Level 1")
    For Each f In fileList
        Debug.Print f
    Next

End Sub

getFileList：功能

Function getFileList(Path As String, Optional FileFilter As String = "*.xls?", Optional fso As Object, Optional list As Object) As Object
    Dim BaseFolder As Object, f As Object

    If fso Is Nothing Then
        Set fso = CreateObject("Scripting.FileSystemObject")
        Set list = CreateObject("System.Collections.ArrayList")
        'Set list = CreateObject("Scripting.Dictionary")
    End If

    If Not Right(Path, 1) = "\" Then Path = Path & "\"
    If Len(Dir(Path, vbDirectory)) = 0 Then
        MsgBox Path & " not found"
        Exit Function
    End If

    Set BaseFolder = fso.GetFolder(Path)
    For Each f In BaseFolder.SubFolders
        getFileList f.Path, FileFilter, fso, list
    Next

    For Each f In BaseFolder.files
        If f.Path Like FileFilter Then list.Add f.Path
    Next

    Set getFileList = list
End Function

Answer 2

以为我得到了它：

Sub Test2()

Dim wb As Workbook, ws As Worksheet
Set fso = CreateObject("Scripting.FileSystemObject")
Set fldr = fso.GetFolder("C:\Users\azrae\OneDrive\Desktop\To Be Transferred\Optimum\Test Folder\")
x = 2
For Each sfldr In fldr.SubFolders

    For Each wbfile In sfldr.Files
        If fso.getextensionname(wbfile.Name) = "xlsx" Then
        Set wb = Workbooks.Open(wbfile.Path)
        End If
        Workbooks("Loop Test.xlsm").Worksheets("Sheet1").Cells(x, 1) = wb.Worksheets("Sheet1").Range("A1")
        Workbooks("Loop Test.xlsm").Worksheets("Sheet1").Cells(x, 2) = wb.Worksheets("Sheet1").Range("A2")
        Workbooks("Loop Test.xlsm").Worksheets("Sheet1").Cells(x, 3) = wb.Worksheets("Sheet1").Range("A3")
        wb.Close
        x = x + 1
    Next wbfile
Next sfldr

End Sub

如果你有一个更顺畅的方法，让我知道。