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