VBA - 将文件夹名称过滤器添加到递归 DIR 搜索

Question

我在实现过滤器以使用 VBA 中的 DIR 函数加速文件搜索方面需要帮助。

背景： 我有一个合同文件夹。 有些合同直接在上面，有些则在单独的“类别”子文件夹中。 所以它看起来像这样：

在每个合约文件夹中，我需要在“2000*\2300*\”中找到一个名称包含“RENS_RES”的文件。我需要获取该文件的路径

情况： 该功能有效。 但它很慢，因为一切都在服务器上，并且有很多文件夹/子文件夹/文件要经过，它会全部测试。最长可能需要 15 分钟。

所以我想让它更快。

现在，我的代码如下所示：

Dim fso 'As New FileSystemObject
Dim fld 'As Folder
Public tampon(120) As Variant 'Where I stock my selected files path
sFol = "C:\something\" The path to my main folder, that contains everything, created as String
sFile = "*RENS_RES*.xlsx" 'The criteria to determine the files to select, created as String
Function FindFile(ByVal sFol As String, sFile As String) As String 'Arguments initially from somewhere else specified
'initially called somewhere else

 Dim tFld, tFil as String 'The currently selected folder and file
 Dim FileName As String  'FileName the name of the selected file

 Set fso = CreateObject("Scripting.FileSystemObject")
 Set fld = fso.GetFolder(sFol)
 FileName = Dir(fso.BuildPath(fld.path, sFile), vbNormal Or _
              vbHidden Or vbSystem Or vbReadOnly) 'I search the first file respecting the criteria sFile
 While Len(FileName) <> 0 'I keep going until all files int he folder are tested
  FindFile = FindFile + FileLen(fso.BuildPath(fld.path, _
  FileName))
  tampon(i) = fso.BuildPath(fld.path, FileName) 'We save the value
  i = i + 1
  FileName = Dir()  ' Get next file
  DoEvents
 Wend

 If fld.SubFolders.Count > 0 Then 'If the current folder has subfolders
  For Each tFld In fld.SubFolders 'We consider each subfolder
    If Not (tFld.Name Like "#000*") Or tFld.Name Like "2000*" Or tFld.Name Like "2300*" Then ' We exclude all the subfolders that start with 4 numbers (format x000) and are not 2000 or 2300 from the search
        DoEvents
        FindFile = FindFile + FindFile(tFld.path, sFile) 'We call again the function to test all files in that subfolder
    End If
  Next
 End If
 Exit Function
Catch:  FileName = ""
   Resume Next
End Function

我试图在子文件夹选择上放置一个过滤器：

If Not (tFld.Name Like "#000*") Or tFld.Name Like "2000*" Or tFld.Name Like "2300*" Then

它具有反转逻辑，因为在“for each loop”中模拟退出。

理论上，如果名称以 4 位数字开头（一个数字后跟三个零，而不是“2000*”或“2300*”（我们要进入的两个文件夹），则理论上不应输入“if”。我有这个是因为类别或合同名称中没有我可以在过滤器上使用的逻辑。

但是过滤器不起作用：它一直遍历每个文件夹，我不明白为什么。 这就是我寻求帮助的地方。

或者是否有另一种更快的搜索方式？

提前感谢您的帮助， 希望我能体面地格式化代码

Answer 1

如果发现这种查找匹配项的非递归方法更容易推理/修改：

'Return a collection of file objects given a starting folder and a file pattern
'  e.g. "*.txt"
'Pass False for last parameter if don't want to check subfolders
Function GetMatches(startFolder As String, filePattern As String, _
                    Optional subFolders As Boolean = True) As Collection

    Dim fso, fldr, f, subFldr
    Dim colFiles As New Collection
    Dim colSub As New Collection

    Set fso = CreateObject("scripting.filesystemobject")
    colSub.Add startFolder

    Do While colSub.Count > 0

        Set fldr = fso.getfolder(colSub(1))
        colSub.Remove 1

        For Each f In fldr.Files
            'check filename pattern
            If UCase(f.Name) Like UCase(filePattern) Then colFiles.Add f
        Next f

        If subFolders Then
            For Each subFldr In fldr.subFolders
                'check subfolder criteria
                'another attempt at your logic...
                If subFldr.Name Like "2000*" or Not subFldr.Name Like "#000*" Then
                    colSub.Add subFldr.Path
                End If
            Next subFldr
        End If

    Loop

    Set GetMatches = colFiles

End Function

示例用法：

Dim colFiles as Collection
Set colFiles = GetMatches("C:\something\", ""*RENS_RES*.xlsx"")