VBA：文件夹路径列表，返回excel文件路径列表，然后编辑excel

Question

我有一个将文件夹路径粘贴到列表中的用户表单。然后我有下面的代码应该循环遍历该列表并列出所有子文件夹（然后我可能会有另一个代码循环遍历子文件夹以获取 excel 工作簿）。

我知道这很不优雅，因为最终我想要的是一次查看我的路径列表，通过每个文件夹和子文件夹查找并列出 excel 文件。但是有 a question 这样的，它被删除了。然后这个问题被提到to a different q&a，我不明白，这与单个文件名有关，在单个单元格中输入，而不是范围，也不是路径。我说俄语，他的一些代码在里面，但仍然不太明白他的代码是什么意思和指的是什么，当我尝试它时，它一直告诉遇见“GetData”未定义？所以我试图问一个不同但类似的问题，希望有人能向我解释我需要做什么，因为我已经尽我所能，并试图从这篇文章的链接中调整这两个代码以及许多其他人。我有几个模块的代码无法正常工作，我最接近的是下面的代码。在这一点上，我只想找到一种从路径列表中列出 excel 文件名的方法。

Option Explicit
Dim i As Long, j As Long
Dim searchfolders As Variant
Dim FileSystemObject

Sub ListOfFolders77()
Dim LookInTheFolder As String
'Dim ws As Worksheet: Set ws = Sheets("Output4")
Dim ws2 As Worksheet: Set ws2 = Sheets("Output3")
Dim rng As Range: Set rng = ws2.Range("A1:A" & Rows.Count).End(xlUp)
Dim mypath As Range
'Dim Region As Range: Set Region = ws.Range("A2")
'Dim district As Range: Set district = ws.Range("B2")
'Dim city As Range: Set city = ws.Range("C2")
'Dim atlas As Range: Set atlas = ws.Range("D2")

i = 1
For Each mypath In rng
    LookInTheFolder = mypath.Value
    Set FileSystemObject = CreateObject("Scripting.FileSystemObject")
    For Each searchfolders In FileSystemObject.GetFolder(LookInTheFolder).subfolders
        Sheets("Subfolders").Cells(i, 1) = searchfolders
        i = i + 1
        SearchWithin searchfolders
    Next searchfolders
Next mypath

End Sub

Sub SearchWithin(searchfolders)
On Error GoTo exits
For Each searchfolders In FileSystemObject.GetFolder(searchfolders).subfolders
j = UBound(Split(searchfolders, "\"))
Cells(i, j) = searchfolders
i = i + 1
SearchWithin searchfolders
Next searchfolders
exits:
End Sub

理想情况下，我想获取文件夹和子文件夹中的所有 excel 文件，并将第一张表上的数据复制粘贴到一个长列表中，但我仍在第 1 步。我发布了更详细的解释 here上周，尚未收到任何反馈或潜在提示。

如果这没有意义或看起来有点危险，我深表歉意。我是在 excel VBA 中自学的，并且正在努力理解我所需要的是否可能。我尝试使用 Directory，但在 for each 循环中放置目录时收效甚微。 我还尝试使用一个数组，当它列出我整个计算机中的所有文件夹和文件时，它几乎被计算机崩溃了。

Answer 1

如果我理解正确，您的要求如下：

• 从一组根路径开始
• 递归遍历每个根路径中的所有文件
• 对于结果集合中的每个文件，如果它是 Excel 文件，则添加到最终列表中以供进一步处理

让我们从前两点开始。我建议使用以下代码（确保在 VBA 编辑器中通过 Tools -> References... 添加对 Microsoft Scripting Runtime 的引用菜单）：

Public Function GetFiles(ByVal roots As Variant) As Collection
    Select Case TypeName(roots)
        Case "String", "Folder"
            roots = Array(roots)
    End Select

    Dim results As New Collection
    Dim fso As New Scripting.FileSystemObject

    Dim root As Variant
    For Each root In roots
        AddFilesFromFolder fso.GetFolder(root), results
    Next

    Set GetFiles = results
End Function

Private Sub AddFilesFromFolder(folder As Scripting.folder, results As Collection)
    Dim file As Scripting.file
    For Each file In folder.Files
        results.Add file
    Next

    Dim subfolder As Scripting.folder
    For Each subfolder In folder.SubFolders
        AddFilesFromFolder subfolder, results
    Next
End Sub

GetFiles 函数可以通过传入单个字符串（或Folder）来调用：

Debug.Print GetFiles("c:\users\win8\documents").Count

或任何可以用For Each 迭代的东西——数组、集合、Dictionary，甚至是Excel Range 对象：

Dim allFiles As Collection
Set allFiles = GetFiles(ws2.Range("A1:A" & Rows.Count).End(xlUp)) 'from question

---

GetFiles 对于许多用例来说是灵活的，并且不使用任何 Excel 特定的对象。为了将结果仅限于 Excel 文件，您可以创建一个新集合，并且只将 Excel 文件添加到新集合中：

'You could filter by the File object's Type property
Sub GetExcelFilesByType()
    Dim allFiles As Collection
    Set allFiles = GetFiles(ws2.Range("A1:A" & Rows.Count).End(xlUp)) 'from question

    Dim excelFiles As New Collection
    Dim file As Scripting.File
    For Each file In allFiles
        If file.Type = "Microsoft Excel Worksheet" Then excelFiles.Add file
    Next
End Sub

' Or you could filter by extension, using the FileSystemObject.GetExtensionName method
Sub GetExcelFilesByExtensionName()
    Dim allFiles As Collection
    Set allFiles = GetFiles(ws2.Range("A1:A" & Rows.Count).End(xlUp)) 'from question

    Dim excelFiles As New Collection
    Dim fso As New Scripting.FileSystemObject
    Dim file As Scripting.File
    For Each file In allFiles
        Select Case fso.GetExtensionName(file.path)
            Case "xls", "xlsb", "xlsm"
                excelFiles.Add file
        End Select
    Next
End Sub

这两种方法都会从根文件夹集中为您提供File 对象中的Collection，仅包含 Excel 文件。

---

注意事项

• 此代码递归地将所有文件（不仅仅是 Excel 文件）添加到一个集合（GetFiles）中，然后将非 Excel 文件过滤到一个新集合中。这可能不如只将 Excel 文件添加到原始集合中，但这会将GetFiles 限制为仅适用于这种情况。
• 如果要将结果粘贴到 Excel 工作表中，可以遍历 excelFiles 并将每个路径粘贴到工作表中。或者，您可以将 excelFiles 转换为数组，并使用 Excel Range 对象的 Value 属性设置数组中的所有值，而不使用 For Each。

---

参考文献

Microsoft Scripting Runtime

• FileSystemObject object, GetExtensionName method
• File object
• Folder object

VBA

• Collection object

Answer 2

这里有一个快速的方法，稍微改编自this answer。

只需将您的文件夹位置添加到path() = ... 列表中，它应该适合您。它在当前的 Excel 工作表中输出您提供的文件夹中所有 Excel 文件的路径。

从那里，您可以随心所欲。 （也许将文件路径放入一个数组中，这样你就有了一个要打开的文件数组。从那里你可以复制数据）。

'Force the explicit delcaration of variables
Option Explicit

Sub ListFiles()
'http://www.xl-central.com/list-the-files-in-a-folder-and-subfolders.html
'Set a reference to Microsoft Scripting Runtime by using
'Tools > References in the Visual Basic Editor (Alt+F11)

'Declare the variables
Dim objFSO  As Scripting.FileSystemObject
Dim objTopFolder As Scripting.Folder
Dim strTopFolderName As String

Dim path()  As Variant ' EDIT THE BELOW PATH LIST FOR WHATEVER YOU NEED!
path() = Array("C:\Users\USERNAME\Desktop\Stuff\New folder", "C:\Users\USERNAME\Desktop\Other Stuff\")

'Insert the headers for Columns
Range("A1").Value = "File Name"
Range("D1").Value = "File Path"

Dim i       As Long
For i = LBound(path) To UBound(path)
    strTopFolderName = path(i)
    'Create an instance of the FileSystemObject
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    'Get the top folder
    Set objTopFolder = objFSO.GetFolder(strTopFolderName)
    'Call the RecursiveFolder routine
    Call RecursiveFolder(objTopFolder, True)
    'Change the width of the columns to achieve the best fit
    Columns.AutoFit
Next i
End Sub

Sub RecursiveFolder(objFolder As Scripting.Folder, _
                    IncludeSubFolders As Boolean)

'Declare the variables
Dim objFile As Scripting.File
Dim objSubFolder As Scripting.Folder
Dim NextRow As Long

'Find the next available row
NextRow = Cells(Rows.Count, "A").End(xlUp).Row + 1

'Loop through each file in the folder
For Each objFile In objFolder.Files
    Debug.Print (objFile)
    If objFile.Type = "Microsoft Excel Worksheet" Then
        Cells(NextRow, "A").Value = objFile.Name
        Cells(NextRow, "D").Value = objFile.path
        NextRow = NextRow + 1
    End If
Next objFile

'Loop through files in the subfolders
If IncludeSubFolders Then
    For Each objSubFolder In objFolder.SubFolders
        Call RecursiveFolder(objSubFolder, True)
    Next objSubFolder
End If

End Sub