VBA Excel execute macro in all subfolders, not only particular folders

Question

I am having problems with my code since it only works in the specific folders but not in all subfolders inside the particular folder.

Could someone please helps to make the code works to all subfolders inside that specific folder? :)

These are my code:

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

Please go through these links and to get ideas for your program — skkakkar, Sep 25 '15 at 14:43

u8it · Answer 1 · 2015-09-25T15:01:40.293

Here's one way to do it with the Dir function. If you want something a little more elegant you may want to consider using a FileSystemObject. (Note that to view Debug.Print output you have to enable the immediate window from under view.)

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

Here's an example of how to do this with a FileSystemObject. Note that my code is a little sloppy with "On error resume next" to protect against access denied or other errors. Realistically you may want to consider incorporating better error handling, but that's another topic. Using a FileSystemObject is more powerful than Dir because Dir only returns a string, while FileSystemObject lets you work with files and folders as actual objects, which are much more powerful.

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 execute macro in all subfolders, not only particular folders

1 Answers1