VBA

Question

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

上下文： 我有一个合同文件夹。有些合同直接在上面，有些在单独的 "category" 子文件夹中。所以它看起来像这样：

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

情况： 该功能有效。但它很慢，因为所有东西都在服务器上，而且有很多 folders/subfolders/files 需要经过，它会测试它们。最多可能需要 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

如果发现这种寻找匹配的非递归方法更容易推理 about/modify:

'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"")

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

VBA - Add a folder name filter to a recursive DIR search

excel

subdirectory