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

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

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

让我知道您是否有更平滑的方法。