VBA Excel在所有子文件夹中执行宏，而不仅仅是特定文件夹

Question

我的代码存在问题，因为它只适用于特定文件夹，但不适用于特定文件夹内的所有子文件夹。

是否有人可以帮助使代码适用于该特定文件夹内的所有子文件夹？ :)

这是我的代码：

Sub Execute1() 
    Dim monthstr As String 
    Dim year As String 
    Dim monthtext As String 
    Dim prevmonth As String 
    Dim prevmonthtext As String 

    year = Range("D8").Text 
    monthstr = Trim(Range("D9").Text) 
    monthtext = Trim(Range("D10").Text) 
    prevmonth = Trim(Range("D11").Text) 
    prevmonthtext = Trim(Range("D12").Text) 
    prevyear = Trim(Range("D13").Text) 

    'confirmation box before running macro////////////////////////////////////////////////////////////////////////////////////// 
    response = MsgBox("Are you sure the settings are correct?", vbYesNo, "Confirmation") 
    If response = vbNo Then 
     Exit Sub 
    End If 

    'optimize macro speed/////////////////////////////////////////////////////////////////////////////////////////////////////////// 
    Call Optimize 

    'finding the correct path (month)////////////////////////////////////////////////////////////////////////////////////////// 
    Dim myfile As String 
    Dim mypath As String 
    Dim newpath As String 

    mypath = "C:\Users\praseirw\Desktop\Tes CC\" & prevyear & "\SC\" & prevmonth & " " & prevmonthtext & "\"  

    myfile = Dir(mypath & "*.xlsx") 

    newpath = "C:\Users\praseirw\Desktop\Tes CC\" & year & "\SC\" & monthstr & " " & monthtext & "\" 

    'loop through all files in specified month////////////////////////////////////////////////////////////////////////////////// 
    Dim root As Workbook 
    Dim rng As Range 
    Dim wb As Workbook 
    Dim ws As Worksheet 

    Set root = Workbooks("CC Reports Center.xlsm") 
    Set rng = root.Worksheets("Settings").Range("H7:H14") 

    Do While myfile <> "" 
     Set wb = Workbooks.Open(mypath & myfile) 
     For Each ws In wb.Worksheets 
      rng.Copy 
      With ws.Range("D1") 
       .PasteSpecial xlPasteFormulas 
      End With 
     Next ws 
     Dim oldname As String 
     Dim newname As String 
     Dim wbname As String 

     oldname = wb.Name 
     wbname = Mid(oldname, 9) 
     newname = year & "_" & monthstr & "_" & wbname 

     wb.SaveAs Filename:=newpath & newname 
     wb.Close 

     Set wb = Nothing 
     myfile = Dir 
    Loop 

    Application.CutCopyMode = False 
    MsgBox "Task Complete!" 

    'reset macro optimization settings////////////////////////////////////////////////////////////////////////////////////////////// 
    Call ResetOptimize 

End Sub 

Answer 1

下面是用Dir函数做这件事。如果你想要一些更优雅的东西，你可以考虑使用FileSystemObject。 （请注意，以查看Debug.Print输出，您必须启用从下图直接窗口。）

Sub test() 
    Dim root As String 
    root = "C:\" 
    Dim DC As New Collection 
    s = Dir(root & "*", vbDirectory) 
    Do Until s = "" 
     DC.Add s 
     s = Dir 
    Loop 
    For Each D In DC 
     Debug.Print D 
     On Error Resume Next: s = Dir(root & D & "\*.xl*"): On Error GoTo 0 
     Do Until s = "" 
      Debug.Print " " & s 
      s = Dir 
     Loop 
    Next 
End Sub 

这里有一个如何使用FileSystemObject的一个做到这一点的例子。请注意，我的代码有点sl with“On error resume next”，以防止拒绝访问或其他错误。实际上，您可能想考虑纳入更好的错误处理，但这是另一个话题。使用FileSystemObject比Dir更强大，因为Dir只返回一个字符串，而FileSystemObject则允许您将文件和文件夹作为实际对象来处理，而实际对象功能更强大。

Sub test() 
'You can use "CreateObject..." to add a FileSystemObject from the Scipting Library 
'Alternatively, you can add a reference to "Microsoft Scripting Runtime" 
'allowing you to directly declare a filesystemobject and access related intellisense 
    Set fso = CreateObject("Scripting.FileSystemObject") 
    Set Folder = fso.GetFolder("C:\") 
    For Each SubFolder In Folder.SubFolders 
     Debug.Print SubFolder.Name 
     On Error Resume Next 
     For Each File In SubFolder.Files 
      Debug.Print " " & File.Name 
     Next 
     On Error GoTo 0 
    Next 
End Sub