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,

 

[josros60]

Any suggestion please.

 

[dmt32]

Any suggestion please.

Hi
assuming your top folder already exists then see if following will do what you want

Sub MakeSubFolders(ByVal TopFolder As String)
    Dim FolderName  As String
    Dim SubFolders  As Variant, SubFolder As Variant
    
    If Right(TopFolder, 1) <> "\" Then TopFolder = TopFolder & "\"
    
    SubFolders = Array("Accruals And AP", "AR And Revenue", "Bank", "FA", "Inventory", "Prepaid_Deposits_Other")
    
    For Each SubFolder In SubFolders
        'get folder name
        FolderName = TopFolder & SubFolder
        'create folder
        If Dir(FolderName, vbDirectory) = vbNullString Then MkDir FolderName
    Next SubFolder
    
End Sub

To call

MakeSubFolders "C:\user\MonthEnd\2025\06 Jun 2025\"

Dave

 

[josros60]

Thank you so much, worked perfectly.

Question how to modify it for me to select the folder in case TopFolder is not created and I will create it at the time.

Thank you, again for your help.

 

[josros60]

Sorry, in other works to prompt for the path.

Thank you,

 

[dmt32]

Question how to modify it for me to select the folder in case TopFolder is not created and I will create it at the time.

Try following update & see if does what you want

Place both codes in a STANDARD module

Sub MakeSubFolders(ByVal TopFolder As String)
    Dim FolderName  As String
    Dim SubFolders  As Variant, SubFolder As Variant
    
    If Dir(TopFolder, vbDirectory) = vbNullString Then
        'show folder picker (current path shown in title bar)
        TopFolder = GetFolder(ThisWorkbook.Path)
        'cancel pressed
        If TopFolder = "" Then Exit Sub
    End If
    
    If Right(TopFolder, 1) <> "\" Then TopFolder = TopFolder & "\"
    
    SubFolders = Array("Accruals And AP", "AR And Revenue", "Bank", "FA", "Inventory", "Prepaid_Deposits_Other")
    
    For Each SubFolder In SubFolders
        'get folder name
        FolderName = TopFolder & SubFolder
        'create folder
        If Dir(FolderName, vbDirectory) = vbNullString Then MkDir FolderName
    Next SubFolder
    
End Sub

Function GetFolder(Optional ByVal Title As String = "Select Folder") As String
    Dim Folder          As FileDialog
    Dim SelectedFolder  As String
    
    Set Folder = Application.FileDialog(msoFileDialogFolderPicker)
    
    With Folder
        .Title = Title
        .AllowMultiSelect = False
        .ButtonName = "Select Folder"
        .InitialFileName = ThisWorkbook.Path
        If .Show = -1 Then SelectedFolder = .SelectedItems(1)
    End With
    
    GetFolder = SelectedFolder
End Function

Dave

 

[josros60]

Still not working or I am doing something when calling macro doesn't prompt for the path it just made subfolder.

This is the line macro button to call it:

MakeSubFolders "\\mtlnas01\share\Accountant Files\Month-EndClosing2025"

Thank you,

 

[dmt32]

Still not working or I am doing something when calling macro doesn't prompt for the path it just made subfolder.

Hi
I am not able to test code on a an unmapped (no drive letter) network drive
you said the first code in its original form, worked for you & with that in mind, try this alternative approach & see if will do what you want.

Place both codes in STANDARD module

Sub MakeSubFolders(ByVal TopFolder As String)
    Dim FolderName  As String
    Dim SubFolders  As Variant, SubFolder As Variant
    
    If Not PathExists(TopFolder) Then Exit Sub
    
    If Right(TopFolder, 1) <> "\" Then TopFolder = TopFolder & "\"
    
    SubFolders = Array("Accruals And AP", "AR And Revenue", "Bank", "FA", "Inventory", "Prepaid_Deposits_Other")
    
    For Each SubFolder In SubFolders
        'get folder name
        FolderName = TopFolder & SubFolder
        'create folder
        If Dir(FolderName, vbDirectory) = vbNullString Then MkDir FolderName
    Next SubFolder
    
End Sub

Function PathExists(ByVal FolderPath As String) As Boolean
    Dim SubFolders()    As String, Folder As String
    Dim i               As Long
    
    On Error GoTo myerror
    SubFolders = Split(FolderPath, "\")
    For i = 0 To UBound(SubFolders)
'build folder path
        Folder = IIf(i = 0, SubFolders(i), Folder & "\" & SubFolders(i))
'create missing folder(s)
        If Dir(Folder, vbDirectory) = vbNullString Then MkDir Folder
    Next
    
    If Dir(FolderPath, vbDirectory) = vbNullString Then Err.Raise 76 Else PathExists = True
     
myerror:
    If Err <> 0 Then MsgBox (Error(Err)), 48, "Error"
End Function

If all works ok, the function PathExists should create any missing Folder(s) in the specified folder path passed to it but I repeat, I am unable to test this on a network drive.

MakeSubFolders "\\mtlnas01\share\Accountant Files\Month-EndClosing2025"

Hope Helpful

Dave

 

[josros60]

Thank you so much, worked perfectly.

 

[dmt32]

Thank you so much, worked perfectly.

Most welcome - glad update resolved the issue & appreciate your feedback

Dave