Prompt for path/folder

[josros60]

Hi,

1. How to modify the code below to prompt for the path (browse for directory/folder)
2. Not sure why when run code it create folder, but after it freeze saying not responding (I have to end task)

here is the code:
Code:

he path (browse for directory/folder)
2. Not sure why when run code create folder but freeze said not responding (I have to end task)

here is the code:
Code:
Sub CreateFolders()

    Dim aCustomers
    Dim aArticles
    Dim i
    Dim j
    Dim sPath

    sPath = "H:\07 Jul 2024\AP_Accruals\"
    With ThisWorkbook.Sheets(1)
        aCustomers = .Range(.Range("A1"), .Range("A1").End(xlDown)).Value
        aArticles = .Range("B1:B9").Value
    End With
    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

   
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

Attached screenshot of file.

 

[John_w]

1. Replace:

    sPath = "H:\07 Jul 2024\AP_Accruals\"

with:

    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Select Folder"
        If .Show Then
            sPath = .SelectedItems(1)
        Else
            Exit Sub
        End If
    End With

2. Possibly because the sPath & "\" part of your code builds a folder path with 2 consecutive backslashes: "H:\07 Jul 2024\AP_Accruals\\.....". The replacement code doesn't have this error.

 

[josros60]

Thank you for responding.

I modified it per your suggestion but still issues:

1. Creating the main folder "MasterCard Corp" and sub folders in from B1:B9 but also is creating the subfolders outside (screenshot files attached)
2. Keep hanging saying not responding (screenshot attached)
3. as you can see screenshot main folder but the sub folders also being created outside (mean twice once inside main folder and outside)

Code:

Sub CreateFolders()

    Dim aCustomers
    Dim aArticles
    Dim i
    Dim j
    Dim sPath
   


    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Select Folder"
        .AllowMultiSelect = False
        '.InitialFileName = "\\mtlnas01\Share\Accountant Files\Month-EndClosing2024"
        If .Show Then
            sPath = .SelectedItems(1)
        Else
            Exit Sub
        End If
    End With
    With ThisWorkbook.Sheets(1)
    
        aCustomers = .Range(.Range("A1"), .Range("A1").End(xlDown)).Value
        aArticles = .Range("B1:B9").Value
    End With
    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


 

   
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

 

[John_w]

I found a bug in your code.

When only A1 is populated, this line:

aCustomers = .Range(.Range("A1"), .Range("A1").End(xlDown)).Value

creates a 2D array from 1 to 1048576, with element 1 containing "MasterCard Corp" and the other elements empty. This is causing the 'Not responding' problem and creating the subfolders outside.

Replace it with:

        aCustomers = .Range("A1:A" & .Cells(.Rows.Count, "A").End(xlUp).Row + 1).Value

and change the outer loop to:

    For i = LBound(aCustomers, 1) To UBound(aCustomers, 1) - 1

The Row + 1 ensures aCustomers is always an array, even when only A1 is populated, and the last element is empty. The UBound(aCustomers, 1) - 1 ignores the last element.

 

[josros60]

Thank you so much, worked perfectly.