VBA create folders and sub folders based upon condition
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
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
ASKER
but sub folders should be created in all folders withing range A:B where B = "Yes"
Please attach the workbook
ASKER
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
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
ASKER
workbook attached
Compliance-Folder-Creator.xlsm
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
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
ASKER
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-
i.e. cell N4/n4 should generate 02-Electrical/03-Contracts
Could you add this requirement? I'm a bit lost.
Thanks
Simon
Compliance-Folder-Creator2.xlsm
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-
i.e. cell N4/n4 should generate 02-Electrical/03-Contracts
Could you add this requirement? I'm a bit lost.
Thanks
Simon
Compliance-Folder-Creator2.xlsm
ASKER CERTIFIED SOLUTION
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
ASKER
Absolutely beautiful solution.
ASKER
Thanks a lot for your work!
ASKER
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