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

Posted 2023-03-27

【中文标题】在多个子文件夹中搜索文件的 VBA 宏

【英文标题】：VBA macro that search for file in multiple subfolders

【发布时间】：2022-01-17 04:58:16

【问题描述】：

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

是否可以在没有特定文件夹位置的情况下完成这项工作？我需要可以通过 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

【参考方案1】：

只是为了好玩，这是一个带有递归函数的示例，（我希望）应该更易于理解并与您的代码一起使用：

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 有点笨拙，因此您可以像这样简单地编写代码（取决于您是否要划分）：

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

【讨论】：

谢谢，我想这正是我想要的。确定这段代码是正确的吗？因为在我的即时面板中，我没有收到来自 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()？喜欢If InStr(1, myFile.Name, Sheets("Sheet1").Range("O5").Value) Then...

【参考方案2】：

此子程序将使用与您传入的文件名或模式匹配的所有文件填充一个集合。

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

用法：

Dim colFiles As New Collection

GetFiles "C:\Users\Marek\Desktop\Makro\", FName & ".xls", True, colFiles
If colFiles.Count > 0 Then
    'work with found files
End If

【讨论】：

我自己用过这个，现在我想弄清楚如果文件夹/子文件夹中没有文件，如何更改单元格颜色。除了我想出来之外，它工作得很好。如果你能帮忙，那就太棒了。我会在这里链接我的问题。 [***.com/questions/62918340/…

【参考方案3】：

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

Sub GetSubFolders()

    Dim fso As New FileSystemObject
    Dim f As Folder, sf As Folder

    Set f = fso.GetFolder("D:\Proj\")
    For Each sf In f.SubFolders
        'Code inside
    Next

End Sub

【参考方案4】：

实际上，我今天刚刚发现这个是为了我正在做的事情。这将返回文件夹及其子文件夹中所有文件的文件路径。

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

本文改编自 Ammara Digital Image Solutions 的帖子。(http://www.ammara.com/access_image_faq/recursive_folder_search.html)。

【讨论】：

你必须设置哪些引用来提前绑定这些东西？