Excel VBA：如何更改代碼以循環通過多個文件夾

Question

此帖與本人以前的問題HERE有關。

在工作簿「CountResults.xlsm」中，我有一個代碼遍歷同一文件夾中不同的excel文件，並從每個文件的特定列中統計「是」的數量。然後它將計數粘貼到「CountResults.xlsm」中。

這是該文件夾先前的樣子看起來像：

現在我的問題是，我的測試文件都將是兩個文件夾內，所以我的代碼是不是能夠把它撿起來。它開始於一個名爲'CodeResults'的文件夾，然後是文件夾'Test0X'，然後'S'，然後是文件名。

ex。 CodeResults - > TEST01 - >的S - > Test01.xls

這是我的文件夾目前是這樣的：

這是我當前的代碼，我需要改變，使它可以在每個文件夾中讀取Excel文件：

Private Sub CommandButton1_Click() 

    Dim r As Range 
    With Worksheets("Sheet1") 
     For Each r In .Range("A2", .Range("A" & .Rows.Count).End(xlUp)) 
      r.Offset(0, 1).Value = getYesCount(r.Value) 
     Next 
    End With 
End Sub 

Function getYesCount(WorkBookName As String) As Long 
    Const FolderPath As String = "C:\Users\khanr1\Desktop\Excel_TEST\CodeUpdateTest" 

    If Len(Dir(FolderPath & WorkBookName)) Then 
     With Workbooks.Open(FolderPath & WorkBookName) 
      With .Worksheets("Sheet2") 
       getYesCount = Application.CountIfs(.Range("D:D"), "YES", _ 
            .Range("B:B"), "*", _ 
            .Range("A:A"), "1") 
      End With 
      .Close False 
     End With 
    Else 
     Debug.Print FolderPath & WorkBookName; ": Not Found" 
    End If 
End Function 

以供參考，這是我的Test01.xls樣子：

這是我的CountResults.xlsm樣子：

注：我試圖找出一個解決方案。我目前使用CountResults.xlsm中的名稱'A'列來查找文件。因此，例如，我可以通過從該列中拉取名稱來打開文件夾Test01。

Answer 1

你需要這樣一個遞歸循環。我會給你兩個樣品做相同的事情。

Option Explicit 

Sub ListAllFiles() 
    'searchForFiles "c:\tushar\temp\", "processOneFile", "*.*", True, True 
    searchForFiles "C:\Users\your_path_here\Desktop\Work Samples\", "writefilestosheet", "*.*", True, True 
End Sub 

Sub processOneFile(ByVal aFilename As String) 
    Debug.Print aFilename 
End Sub 

Sub writeFilesToSheet(ByVal aFilename As String) 
    With ActiveSheet 
    .Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0).Value = aFilename 
     End With 
End Sub 


    Private Sub processFiles(ByVal DirToSearch As String, _ 
      ByVal ProcToCall As String, _ 
      ByVal FileTypeToFind As String) 
     Dim aFile As String 
     aFile = Dir(DirToSearch & FileTypeToFind) 
     Do While aFile <> "" 
      Application.Run ProcToCall, DirToSearch & aFile 
      aFile = Dir() 
      Loop 
End Sub 

Private Sub processSubFolders(ByVal DirToSearch As String, _ 
      ByVal ProcToCall As String, _ 
      ByVal FileTypeToFind As String, _ 
      ByVal SearchSubDir As Boolean, _ 
      ByVal FilesFirst As Boolean) 

Dim aFolder As String, SubFolders() As String 

ReDim SubFolders(0) 

aFolder = Dir(DirToSearch, vbDirectory) 

    Do While aFolder <> "" 

     If aFolder <> "." And aFolder <> ".." Then 

      If (GetAttr(DirToSearch & aFolder) And vbDirectory) _ 
        = vbDirectory Then 
       SubFolders(UBound(SubFolders)) = aFolder 
       ReDim Preserve SubFolders(UBound(SubFolders) + 1) 
       End If 
       End If 
      aFolder = Dir() 
      Loop 

     If UBound(SubFolders) <> LBound(SubFolders) Then 
      Dim i As Long 
      For i = LBound(SubFolders) To UBound(SubFolders) - 1 
       searchForFiles _ 
        DirToSearch & SubFolders(i), _ 
        ProcToCall, FileTypeToFind, SearchSubDir, FilesFirst 
       Next i 
      End If 

    End Sub 

Sub searchForFiles(ByVal DirToSearch As String, ByVal ProcToCall As String, _ 
     Optional ByVal FileTypeToFind As String = "*.*", _ 
     Optional ByVal SearchSubDir As Boolean = False, _ 
     Optional ByVal FilesFirst As Boolean = False) 
    On Error GoTo ErrXIT 
    If Right(DirToSearch, 1) <> Application.PathSeparator Then _ 
     DirToSearch = DirToSearch & Application.PathSeparator 

If FilesFirst Then processFiles DirToSearch, ProcToCall, FileTypeToFind 
If SearchSubDir Then processSubFolders DirToSearch, ProcToCall, _ 
    FileTypeToFind, SearchSubDir, FilesFirst 

    If Not FilesFirst Then _ 
     processFiles DirToSearch, ProcToCall, FileTypeToFind 
    Exit Sub 
ErrXIT: 
    MsgBox "Fatal error: " & Err.Description & " (Code=" & Err.Number & ")" 
    Exit Sub 
End Sub 

ALSO

Option Explicit 

Sub TestListFolders() 

    Application.ScreenUpdating = False 

    'create a new workbook for the folder list 

    'commented out by dr 
    'Workbooks.Add 

    'line added by dr to clear old data 
    Cells.Delete 

    ' add headers 
    With Range("A1") 
     .Formula = "Folder contents:" 
     .Font.Bold = True 
     .Font.Size = 12 
    End With 

    Range("A3").Formula = "Folder Path:" 
    Range("B3").Formula = "Folder Name:" 
    Range("C3").Formula = "Size:" 
    Range("D3").Formula = "Subfolders:" 
    Range("E3").Formula = "Files:" 
    Range("F3").Formula = "Short Name:" 
    Range("G3").Formula = "Short Path:" 
    Range("A3:G3").Font.Bold = True 

    'ENTER START FOLDER HERE 
    ' and include subfolders (true/false) 
    ListFolders "C:\Users\your_path_here\Desktop\Work Samples\", True 

    Application.ScreenUpdating = True 

End Sub 

Sub ListFolders(SourceFolderName As String, IncludeSubfolders As Boolean) 
    ' lists information about the folders in SourceFolder 
    ' example: ListFolders "C:\", True 
    Dim FSO As Scripting.FileSystemObject 
    Dim SourceFolder As Scripting.Folder, SubFolder As Scripting.Folder 
    Dim r As Long 

    Set FSO = New Scripting.FileSystemObject 
    Set SourceFolder = FSO.GetFolder(SourceFolderName) 

    'line added by dr for repeated "Permission Denied" errors 

    On Error Resume Next 

    ' display folder properties 
    r = Range("A65536").End(xlUp).Row + 1 
    Cells(r, 1).Formula = SourceFolder.Path 
    Cells(r, 2).Formula = SourceFolder.Name 
    Cells(r, 3).Formula = SourceFolder.Size 
    Cells(r, 4).Formula = SourceFolder.SubFolders.Count 
    Cells(r, 5).Formula = SourceFolder.Files.Count 
    Cells(r, 6).Formula = SourceFolder.ShortName 
    Cells(r, 7).Formula = SourceFolder.ShortPath 
    If IncludeSubfolders Then 
     For Each SubFolder In SourceFolder.SubFolders 
      ListFolders SubFolder.Path, True 
     Next SubFolder 
     Set SubFolder = Nothing 
    End If 

    Columns("A:G").AutoFit 

    Set SourceFolder = Nothing 
    Set FSO = Nothing 

    'commented out by dr 
    'ActiveWorkbook.Saved = True 

End Sub