Excel VBA：搜索不包括某些子目录的文件的文件夹和子目录

Question

我发现了一些在线搜索目录的代码，它是满足搜索条件的文件的子目录。

我想修改这个代码：第一个匹配的文件中发现

忽略所有子目录与它的名字（“历史记录”“历史”，“历史”后

1. 停止等）

谁创造的目录结构中使用文件名中的空间的人，这样的文件夹的例子忽略包括“工具史”，所有子目录中的“工具史”

我发现的代码如下（抱歉，没有引用来源，我不记得在那里我发现它）

Function RecursiveDir(colFiles As Collection, _ 
          strFolder As String, _ 
          strFileSpec As String, _ 
          bIncludeSubfolders As Boolean) 
    ' Search a folder and each of its subfolders for any files that meet the citerion given in 
    ' strFileSpec 

    ' colFiles - the name of the collection to add the output to 
    ' strFolder - The path to the parent directory 
    ' strFileSpec - The condition of the filename being searched for (for example all pdf files) 
    ' bIncludeSubfolders - Boolean, include all subfolders in the search 

    ' THIS FUNCTION IS SUBOPTIMAL AND VERY SLOW, PLEASE REVISIT IF USED REGULARLY 

    Dim strTemp As String 
    Dim colFolders As New Collection 
    Dim vFolderName As Variant 

    'Add files in strFolder matching strFileSpec to colFiles 
    strFolder = TrailingSlash(strFolder) 
    strTemp = Dir(strFolder & strFileSpec) 
    Do While strTemp <> vbNullString 
     colFiles.Add strFolder & strTemp 
     strTemp = Dir 
    Loop 

    If bIncludeSubfolders Then 
     'Fill colFolders with list of subdirectories of strFolder 
     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 

Function TrailingSlash(strFolder As String) As String 
    ' Search for and remove a trailing slash in the directory pathname 
    If Len(strFolder) > 0 Then 
     If Right(strFolder, 1) = "\" Then 
      TrailingSlash = strFolder 
     Else 
      TrailingSlash = strFolder & "\" 
     End If 
    End If 
End Function 

此代码是非常缓慢的，所以如果有人有任何更快，我将非常感激。

非常感谢

Answer 1

如果我是你，我会这样做。

Sub ListFilesInFolders() 

Range("A:C").ClearContents 
Range("A1").Value = "Folder Name" 
Range("B1").Value = "File Name" 
Range("C1").Value = "File Short Path" 
Range("D1").Value = "File Type" 
Range("A1").Select 

Dim strPath As String 
Dim sht As Worksheet 
Dim LastRow As Long 



'strPath = "C:\Data Collection\" 
strPath = GetFolder 

Dim OBJ As Object, Folder As Object, File As Object 

Set OBJ = CreateObject("Scripting.FileSystemObject") 
Set Folder = OBJ.GetFolder(strPath) 

Call ListFiles(Folder) 

Dim SubFolder As Object 

For Each SubFolder In Folder.SubFolders 
    Call ListFiles(SubFolder) 
    Call GetSubFolders(SubFolder) 
Next SubFolder 

MsgBox ("DONE!!!") 
End Sub 

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' 

Sub ListFiles(ByRef Folder As Object) 

If Folder Like "*History*" Then 
    Exit Sub 
End If 

Set sht = ThisWorkbook.Worksheets("Sheet1") 

'Ctrl + Shift + End 
r = sht.Cells(sht.Rows.Count, "A").End(xlUp).Row + 1 

With ActiveSheet 

On Error Resume Next 
For Each File In Folder.Files 

     .Cells(r, 1).Value = File.ParentFolder 
     .Cells(r, 2).Value = File.ShortName 
     .Cells(r, 3).Value = File.ShortPath 
     .Cells(r, 4).Value = File.Type 

r = r + 1 
Next File 

End With 

End Sub 

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' 

Sub GetSubFolders(ByRef SubFolder As Object) 

Dim FolderItem As Object 
On Error Resume Next 
For Each FolderItem In SubFolder.SubFolders 
    Call ListFiles(FolderItem) 
    Call GetSubFolders(FolderItem) 
Next FolderItem 

End Sub 


Function GetFolder() As String 
    Dim fldr As FileDialog 
    Dim sItem As String 
    Set fldr = Application.FileDialog(msoFileDialogFolderPicker) 
    With fldr 
     .Title = "Select a Folder" 
     .AllowMultiSelect = False 
     .InitialFileName = Application.DefaultFilePath 
     If .Show <> -1 Then GoTo NextCode 
     sItem = .SelectedItems(1) 
    End With 
NextCode: 
    GetFolder = sItem 
    Set fldr = Nothing 
End Function