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

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

有人可以帮助使代码工作到该特定文件夹内的所有子文件夹？ 🙂

这些是我的代码：

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”，以防止拒绝访问或其他错误。 实际上，你可能想考虑纳入更好的error handling，但这是另一个话题。 使用FileSystemObject比Dir更强大，因为Dir只返回一个string，而FileSystemObject则允许您将文件和文件夹作为实际的对象来处理，而实际的对象function更强大。

 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