VBA create folders and sub folders based upon condition

Simon Raine
Simon Raine used Ask the Experts™
on
Create the same sub folders within multiple folders based upon cell value

I have created the attached sheet.  The sheet creates folders and sub folders. I have managed to create the list of Contractor Sub Folders into the "01-Gas heating" level 1 folder.

I want to create the contractor folders in all level 1 folders where contractor folder (column B) equals Yes.

Thanks

Simon
Comment
Watch Question

Do more with

Expert Office
EXPERT OFFICE® is a registered trademark of EXPERTS EXCHANGE®

Author

Commented:
current code


Sub contractorcreate()

' Creates contractor sub folders to paste into applicable folders

    Dim myLastRow As Long, myRow As Long
   
    Dim val As String
    val = Range("A3").Value
   

'   Find last row in column
    myLastRow = Cells(Rows.Count, "F").End(xlUp).Row

'   Loop through all rows in starting with row 2
    For myRow = 2 To myLastRow
        If Len(Dir(ThisWorkbook.Path & "\" & val & "\" & Cells(myRow, "F"), vbDirectory)) = 0 Then
            ' On Error Resume Next
            MkDir (ThisWorkbook.Path & "\" & val & "\" & Cells(myRow, "F"))
            ' On Error GoTo 0
        End If
    Next myRow



End Sub

Author

Commented:
but sub folders should be created in all folders withing range A:B where B = "Yes"
Please attach the workbook

Author

Commented:
Hi

Workbook attached.

At the moment I have coded each line, but I want to change this to loop through column A only insert sub folders where column b = "yes"



Sub contractorcreate()

' Creates contractor sub folders to paste into applicable folders

    Dim myLastRow As Long, myRow As Long
   
    Dim val1 As String
   
    val1 = Range("A3").Value
    val2 = Range("A4").Value
    val3 = Range("A5").Value
    val4 = Range("A6").Value
    val5 = Range("A7").Value
   

'   Find last row in column
    myLastRow = Cells(Rows.Count, "F").End(xlUp).Row

'   Val1
    For myRow = 2 To myLastRow
        If Len(Dir(ThisWorkbook.Path & "\" & val1 & "\" & Cells(myRow, "F"), vbDirectory)) = 0 Then
            ' On Error Resume Next
            MkDir (ThisWorkbook.Path & "\" & val1 & "\" & Cells(myRow, "F"))
            ' On Error GoTo 0
        End If
    Next myRow
   
    '   Val2
    For myRow = 2 To myLastRow
        If Len(Dir(ThisWorkbook.Path & "\" & val2 & "\" & Cells(myRow, "F"), vbDirectory)) = 0 Then
            ' On Error Resume Next
            MkDir (ThisWorkbook.Path & "\" & val2 & "\" & Cells(myRow, "F"))
            ' On Error GoTo 0
        End If
    Next myRow
   
    '   Val3
    For myRow = 2 To myLastRow
        If Len(Dir(ThisWorkbook.Path & "\" & val3 & "\" & Cells(myRow, "F"), vbDirectory)) = 0 Then
            ' On Error Resume Next
            MkDir (ThisWorkbook.Path & "\" & val3 & "\" & Cells(myRow, "F"))
            ' On Error GoTo 0
        End If
    Next myRow

    '   Val4
    For myRow = 2 To myLastRow
        If Len(Dir(ThisWorkbook.Path & "\" & val4 & "\" & Cells(myRow, "F"), vbDirectory)) = 0 Then
            ' On Error Resume Next
            MkDir (ThisWorkbook.Path & "\" & val4 & "\" & Cells(myRow, "F"))
            ' On Error GoTo 0
        End If
    Next myRow
   
        '   Val5
    For myRow = 2 To myLastRow
        If Len(Dir(ThisWorkbook.Path & "\" & val5 & "\" & Cells(myRow, "F"), vbDirectory)) = 0 Then
            ' On Error Resume Next
            MkDir (ThisWorkbook.Path & "\" & val5 & "\" & Cells(myRow, "F"))
            ' On Error GoTo 0
        End If
    Next myRow


End Sub


Sub procurementcreate()


    Dim myLastRow As Long, myRow As Long
   

'   Find last row in column
    myLastRow = Cells(Rows.Count, "J").End(xlUp).Row

'   Loop through all rows in starting with row 2
    For myRow = 2 To myLastRow
        If Len(Dir(ThisWorkbook.Path & "\" & Cells(myRow, "J"), vbDirectory)) = 0 Then
            'On Error Resume Next
            MkDir (ThisWorkbook.Path & "\" & Cells(myRow, "J"))
            ' On Error GoTo 0
        End If
    Next myRow



End Sub

Author

Commented:
workbook attached
Compliance-Folder-Creator.xlsm
Have a look at this. Did a bunch of changes to keep the VBA as simple as possible.
The 1st column is always the subfolder name
The 2nd column is the optional sub-folder column name
The 3rd column is always empty

The VBA checks if a subfolder column name is found and creates the subfolders recursively (instead of yes). Therefore the subfolder column names must be unique. The column named "Contracts Sub Folders" is the last it will process

Hope it will do what you require.
Compliance-Folder-Creator2.xlsm

Author

Commented:
Hi Michael

The simplicity of this is simply beautiful.

However your new version remove a requirement of the first. The procurement and contracts sub folders are not universal. i.e. they go into specific sub folders linked to their level one folder.

I have adjusted your version, with columns for the user to state the level 1 folder for the procurement and contrracts sub folders,

i.e. cell J2 /K2 should generate 01-Gas heating/02-Procurement/01-London Gas
i.e. cell N4/n4 should generate 02-Electrical/03-Contracts/01-Digi

Could you add this requirement? I'm a bit lost.

Thanks

Simon
Compliance-Folder-Creator2.xlsm
Sorry missed that requirement. Its now working as desired.
Compliance-Folder-Creator3.xlsm

Author

Commented:
Absolutely beautiful solution.

Author

Commented:
Thanks a lot for your work!

Do more with

Expert Office
Submit tech questions to Ask the Experts™ at any time to receive solutions, advice, and new ideas from leading industry professionals.

Start 7-Day Free Trial