Excel VBA：いくつかのサブディレクトリを除いたファイルのフォルダとサブディレクトリを検索

Question

ディレクトリを検索するコードがオンライン上にあり、検索条件を満たすファイルのサブディレクトリです。最初に一致するファイルが

はそれの名前（「歴史」、「歴史」内の「履歴」を持つすべてのサブディレクトリを無視発見された後

1. 停止：私はこのコードを編集したい

   など）

フォルダーの例は、「ツールの履歴」を含める無視するように、ディレクトリ構造を作成した者は、ファイル名に「ツール史」

内のすべてのサブディレクトリをスペースを使用しています210

私が発見したコードは、このコードは非常に遅いので、誰もが速く何かを持っている場合、私は本当に感謝される

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