Create Sub-folder in Each of the Folders in a Browsed Directory

[damaniam1604]

Essentially, I want to be able to highlight a list in a column and run the macro. The end result would be that the macro would allow me to browse for the desired folder and within each sub-folder of the desired folder, a file for each name on the list will be created.

For example, I want to create 12 month named folders in each company's file. There are 17 company files in the desired directory.

Any help would be greatly appreciated. Thanks in advance.

 

[Leith Ross]

Hello damaniam1604,

This macro will let you select the folder and then add new folders using the range selected on the worksheet.

Sub AddSubFolders()


    Dim Cell        As Range
    Dim Folder      As Variant
    Dim SubFolders  As Object
    Dim Rng         As Range
    
        If TypeName(Selection) <> "Range" Then Exit Sub
        
        With Application.FileDialog(msoFileDialogFolderPicker)
            If .Show Then Folder = .SelectedItems(1) Else Exit Sub
        End With
        
        With CreateObject("Shell.Application")
            Set SubFolders = .Namespace(Folder).Items
                SubFolders.Filter 32, "*"
            If SubFolders.Count = 0 Then
                MsgBox "There are No Subfolders in this Directory.", vbExclamation
                Exit Sub
            End If
        End With
        
        For Each Folder In SubFolders
            If Not (Folder.Type Like "Compressed*") Then
                For Each Cell In Rng.Cells
                    On Error Resume Next
                        MkDir Folder.Path & "\" & Cell.Text
                    On Error GoTo 0
                Next Cell
            End If
        Next Folder
        
End Sub

 

[damaniam1604]

Thank you for your response. I can't get the code to run without error. It returns a run-time error '91': Object variable or With block variable not set. It points to the link "For Each Cell In Rng.Cells" as the error in debug mode.

 

[Leith Ross]

Hello damaniam1604,

Sorry, I forgot to change the code after troubleshooting it. Try this...

[/COLOR]Sub AddSubFolders()


    Dim Cell        As Range
    Dim Folder      As Variant
    Dim SubFolders  As Object
    Dim Rng         As Range
    
        If TypeName(Selection) <> "Range" Then Exit Sub Else Set Rng = Selection
        
        With Application.FileDialog(msoFileDialogFolderPicker)
            If .Show Then Folder = .SelectedItems(1) Else Exit Sub
        End With
        
        With CreateObject("Shell.Application")
            Set SubFolders = .Namespace(Folder).Items
                SubFolders.Filter 32, "*"
            If SubFolders.Count = 0 Then
                MsgBox "There are No Subfolders in this Directory.", vbExclamation
                Exit Sub
            End If
        End With
        
        For Each Folder In SubFolders
            If Not (Folder.Type Like "Compressed*") Then
                For Each Cell In Rng.Cells
                    On Error Resume Next
                        If Cell <> "" Then MkDir Folder.Path & "\" & Cell.Text
                    On Error GoTo 0
                Next Cell
            End If
        Next Folder
        
End Sub