在多个子文件夹中搜索文件的VBA宏

我有宏，如果我在单元格E1中输入文件名，通过C:\Users\Marek\Desktop\Makro\directory进行宏搜索，找到它并用宏将所需的值放入原始文件的特定单元格中

是否可以在没有特定文件夹位置的情况下执行此操作？我需要一些可以通过C:\Users\Marek\Desktop\Makro\搜索的东西，其中有很多子文件夹

我的代码：

Sub Zila1()
Dim SaveDriveDir As String, MyPath As String
Dim FName As Variant
Dim YrMth As String

SaveDriveDir = CurDir
MyPath = Application.DefaultFilePath    'or use "C:\Data"
ChDrive MyPath
ChDir MyPath
FName = Sheets("Sheet1").Range("E1").Text

If FName = False Then
    'do nothing
Else
    GetData "C:\Users\Marek\Desktop\Makro\" & FName & ".xls", "Vystupna_kontrola", _
        "A16:A17", Sheets("Sheet1").Range("B2:B3"), True, False

        GetData "C:\Users\Marek\Desktop\Makro\" & FName & ".xls", "Vystupna_kontrola", _
        "AE23:AE24", Sheets("Sheet1").Range("B3:B4"), True, False

        GetData "C:\Users\Marek\Desktop\Makro\" & FName & ".xls", "Vystupna_kontrola", _
        "AE26:AE27", Sheets("Sheet1").Range("B4:B5"), True, False

        GetData "C:\Users\Marek\Desktop\Makro\" & FName & ".xls", "Vystupna_kontrola", _
        "AQ59:AQ60", Sheets("Sheet1").Range("B5:B6"), True, False

        GetData "C:\Users\Marek\Desktop\Makro\" & FName & ".xls", "Vystupna_kontrola", _
        "AR65:AR66", Sheets("Sheet1").Range("B6:B7"), True, False

        End If

  ChDrive SaveDriveDir
  ChDir SaveDriveDir
End Sub

---

此子项将使用与传入的文件名或模式匹配的所有文件填充集合

Sub GetFiles(StartFolder As String, Pattern As String, _
             DoSubfolders As Boolean, ByRef colFiles As Collection)

    Dim f As String, sf As String, subF As New Collection, s
    
    If Right(StartFolder, 1) <> "\" Then StartFolder = StartFolder & "\"
    
    f = Dir(StartFolder & Pattern)
    Do While Len(f) > 0
        colFiles.Add StartFolder & f
        f = Dir()
    Loop
    
    If DoSubfolders then
        sf = Dir(StartFolder, vbDirectory)
        Do While Len(sf) > 0
            If sf <> "." And sf <> ".." Then
                If (GetAttr(StartFolder & sf) And vbDirectory) <> 0 Then
                        subF.Add StartFolder & sf
                End If
            End If
            sf = Dir()
        Loop
    
        For Each s In subF
            GetFiles CStr(s), Pattern, True, colFiles
        Next s
    End If

End Sub

---

如果这有帮助，还可以使用FileSystemObject检索文件夹的所有子文件夹。 您需要检查参考“MicrosoftScriptingRuntime”以获取Intellisense并使用“new”关键字

---

事实上，我今天才发现这是我正在研究的东西。这将返回文件夹及其子文件夹中所有文件的文件路径

Dim colFiles As New Collection
RecursiveDir colFiles, "C:\Users\Marek\Desktop\Makro\", "*.*", True
Dim vFile As Variant

For Each vFile In colFiles
     'file operation here or store file name/path in a string array for use later in the script
     filepath(n) = vFile
     filename = fso.GetFileName(vFile) 'If you want the filename without full path
     n=n+1
Next vFile


'These two functions are required
Public Function RecursiveDir(colFiles As Collection, strFolder As String, strFileSpec As String, bIncludeSubfolders As Boolean)
Dim strTemp As String
Dim colFolders As New Collection
Dim vFolderName As Variant
strFolder = TrailingSlash(strFolder)
strTemp = Dir(strFolder & strFileSpec)
Do While strTemp <> vbNullString
    colFiles.Add strFolder & strTemp
    strTemp = Dir
Loop
If bIncludeSubfolders Then

    strTemp = Dir(strFolder, vbDirectory)
    Do While strTemp <> vbNullString
        If (strTemp <> ".") And (strTemp <> "..") Then
            If (GetAttr(strFolder & strTemp) And vbDirectory) <> 0 Then
                colFolders.Add strTemp
            End If
        End If
        strTemp = Dir
    Loop
    'Call RecursiveDir for each subfolder in colFolders
    For Each vFolderName In colFolders
        Call RecursiveDir(colFiles, strFolder & vFolderName, strFileSpec, True)
    Next vFolderName
End If
End Function

Public Function TrailingSlash(strFolder As String) As String
If Len(strFolder) > 0 Then
    If Right(strFolder, 1) = "\" Then
        TrailingSlash = strFolder
    Else
        TrailingSlash = strFolder & "\"
    End If
End If
End Function

Dim colfile作为新集合
RecursiveDir colFiles，“C:\Users\Marek\Desktop\Makro\”，“***”，True
作为变量的Dim vFile
对于colFiles中的每个vFile
'文件操作，或将文件名/路径存储在字符串数组中，以供以后在脚本中使用
文件路径（n）=vFile
filename=fso.GetFileName（vFile）“”如果希望文件名没有完整路径
n=n+1
下一个vFile
"这两个功能是必须的
公共函数RecursiveDir（colFiles作为集合，strFolder作为字符串，strFileSpec作为字符串，bIncludeSubfolders作为布尔值）
将strTemp设置为字符串
将文件夹设置为新集合
Dim vFolderName作为变体
strFolder=TrailingSlash（strFolder）
strTemp=Dir（strFolder和strFileSpec）
当strTemp vbNullString时执行
添加strFolder和strTemp
strTemp=Dir
环
如果bIncludeSubfolders，则
strTemp=Dir（strFolder，vbDirectory）
当strTemp vbNullString时执行
如果（strTemp“.”）和（strTemp“.”），则
如果（GetAttr（strFolder&strTemp）和vbDirectory）0，则
colFolders.addstrtemp
如果结束
如果结束
strTemp=Dir
环
'为colFolders中的每个子文件夹调用RecursiveDir
对于colFolders中的每个vFolderName
调用RecursiveDir（colFiles、strFolder和vFolderName、strFileSpec、True）
下一个vFolderName
如果结束
端函数
公共函数TrailingSlash（strFolder作为字符串）作为字符串
如果Len（strFolder）>0，则
如果正确（strFolder，1）=“\”则
TrailingSlash=strFolder
其他的
TrailingSlash=strFolder&“\”
如果结束
如果结束
端函数

---

这篇文章改编自Ammara Digital Image Solutions的一篇文章。（

为了好玩，这里有一个递归函数的示例，我希望它应该更容易理解，也更容易与代码一起使用：

Function Recurse(sPath As String) As String

    Dim FSO As New FileSystemObject
    Dim myFolder As Folder
    Dim mySubFolder As Folder

    Set myFolder = FSO.GetFolder(sPath)
    For Each mySubFolder In myFolder.SubFolders
        Call TestSub(mySubFolder.Path)
        Recurse = Recurse(mySubFolder.Path)
    Next

End Function

Sub TestR()

    Call Recurse("D:\Projets\")

End Sub

Sub TestSub(ByVal s As String)

    Debug.Print s

End Sub

编辑：以下是如何在工作簿中实现此代码以实现目标

Sub TestSub(ByVal s As String)

    Dim FSO As New FileSystemObject
    Dim myFolder As Folder
    Dim myFile As File

    Set myFolder = FSO.GetFolder(s)
    For Each myFile In myFolder.Files
        If myFile.Name = Range("E1").Value Then
            Debug.Print myFile.Name 'Or do whatever you want with the file
        End If
    Next

End Sub

在这里，我只调试找到的文件的名称，其余的由您决定。；）

当然，有些人会说调用两次FileSystemObject有点笨拙，这样您就可以像这样编写代码（取决于您是否要划分）：

---

谢谢，我想这正是我想要的。你确定这个代码是正确的吗？因为在我的即时面板中，我没有从Debug.print获得任何响应，它只会在子文件夹中的一个文件与E1中的名称匹配时调试文件名（因此请确保先验证条件）。如果您想在调试窗口中查看所有文件，只需注释条件行（“If”和“end If”以及“exit for”），请说明我如何改进这部分代码：对于mySubFolder.files中的每个myFile.If myFile.Name=Sheets（“Sheet1”）.Range（“O5”）.Value&“.xlsx”，然后。。。。。。。如果我还想找到一个扩展名为xls的文件。最好说我想找到我放在O5范围内的文件名，不管它是xls还是xlsx。谢谢@trenccan抱歉，伙计，我最近没有检查过这条线。你试过查看InStr（）吗？比如

如果InStr（1，myFile.Name，Sheets（“Sheet1”）.Range（“O5”）.Value），那么…

您必须设置哪些引用来提前绑定这些东西？我自己已经用过了，现在我正试图弄清楚如果在文件夹/子文件夹中找不到文件，如何更改单元格颜色。除了我弄明白这一点之外，它工作得很好。如果你能帮忙，那就太棒了。我将把我的问题链接到这里。[

Function Recurse(sPath As String) As String

    Dim FSO As New FileSystemObject
    Dim myFolder As Folder
    Dim mySubFolder As Folder

    Set myFolder = FSO.GetFolder(sPath)
    For Each mySubFolder In myFolder.SubFolders
        Call TestSub(mySubFolder.Path)
        Recurse = Recurse(mySubFolder.Path)
    Next

End Function

Sub TestR()

    Call Recurse("D:\Projets\")

End Sub

Sub TestSub(ByVal s As String)

    Debug.Print s

End Sub

Sub TestSub(ByVal s As String)

    Dim FSO As New FileSystemObject
    Dim myFolder As Folder
    Dim myFile As File

    Set myFolder = FSO.GetFolder(s)
    For Each myFile In myFolder.Files
        If myFile.Name = Range("E1").Value Then
            Debug.Print myFile.Name 'Or do whatever you want with the file
        End If
    Next

End Sub

Function Recurse(sPath As String) As String

    Dim FSO As New FileSystemObject
    Dim myFolder As Folder
    Dim mySubFolder As Folder
    Dim myFile As File

    Set myFolder = FSO.GetFolder(sPath)

    For Each mySubFolder In myFolder.SubFolders
        For Each myFile In mySubFolder.Files
            If myFile.Name = Range("E1").Value Then
                Debug.Print myFile.Name & " in " & myFile.Path 'Or do whatever you want with the file
                Exit For
            End If
        Next
        Recurse = Recurse(mySubFolder.Path)
    Next

End Function

Sub TestR()

    Call Recurse("D:\Projets\")

End Sub