Creating Sub folders

[josros60]

Hi,

I have the code below how can it be modify to create sub folders in already year folders created with another macro,

I would like to create the following sub folders in a already created month end folder like:
C:\user\MonthEnd\2025\06 Jun 2025\

Accruals andAP AR and Revenue Bank FA Inventory Prepaid_Deposits_Other

in t

Sub CreateFolders()

    Dim aCustomers
    Dim aArticles
    Dim i
    Dim j
    Dim sPath
    Dim Msg As String




    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Select Folder"
        .AllowMultiSelect = False
        .InitialFileName = "\\mtlnas01\Share\Accountant Files\Month-EndClosing2025"
        If .Show Then
            sPath = .SelectedItems(1)
        Else
            Exit Sub
        End If
    End With
    With ThisWorkbook.Sheets(1)
    aCustomers = .Range("A1:A" & .Cells(.Rows.Count, "A").End(xlUp).Row + 1).Value
    'aCustomers = .Range(.Range("A1"), .Range("A1").End(xlDown)).Value
        
        aArticles = .Range("B1:B7").Value
    End With
       
       For i = LBound(aCustomers, 1) To UBound(aCustomers, 1) - 1
    'For i = LBound(aCustomers, 1) To UBound(aCustomers, 1)
        For j = LBound(aArticles, 1) To UBound(aArticles, 1)
            SmartCreateFolder sPath & "\" & aCustomers(i, 1) & "\" & aArticles(j, 1)
        Next
    Next

MsgBox "Operation Complete.Employee BMO mastercard subfolders have been created in BMO MASTERCARD CORP. FOLDER." & Msg

  
End Sub

Sub SmartCreateFolder(sFolder)

    Static oFSO As Object

    If oFSO Is Nothing Then Set oFSO = CreateObject("Scripting.FileSystemObject")
    With oFSO
        If Not .FolderExists(sFolder) Then
            SmartCreateFolder .GetParentFolderName(sFolder)
            .CreateFolder sFolder
        End If
    End With

End Sub

Thank you,