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执行此操作的示例。请注意，我的代码有点邋with＆＃34; On error resume next＆＃34;防止访问被拒绝或其他错误。实际上，您可能需要考虑合并更好的错误处理，但这是另一个主题。使用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

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

1 个答案: