Create folders and Subfolders (from) Single Excel Column

[FenHow]

Hi, I have a list in excel, image attached, I am trying to create a folder structure using VBA that will nest the sub folders with the numbering as shown. I think I have seen this before but cannot for the life of me find where.
I have been using this code and it works great but it does not nest the folders. Once all the folders are created I have to manually move them. Can anyone help me solve this?
Many thanks in advance.
Fen

Sub CreateFolderStructure()
Dim objRow As Range, objCell As Range, strFolders As String

For Each objRow In ActiveSheet.UsedRange.Rows
strFolders = "C:\Folder Name Here"
For Each objCell In objRow.Cells
strFolders = strFolders & "\" & objCell
Next
Shell ("cmd /c md " & Chr(34) & strFolders & Chr(34))
Next
End Sub

 

[Herakles]

Can you plese post all of the contents of column A as text so that I can run it with those folder names?

 

[FenHow]

1.0 - CORPORATE

1.1 - Management

1.1.1 - Circon

1.1.2 - Development Overhead

1.1.3 - Investment/Capital Management Contractor

1.1.3.1 - Investment Management Contract

1.1.3.2 - Capital Procurement Contract

1.2 - Agreements

1.2.1 - Partnership Agreements

1.2.2 - JV Agreement

1.2.3 - Shared Services

1.2.4 - Funding Agreements

2.0 - DEVELOPMENT

2.1 - Development Success Fee

2.1.1 - Development Fee (1 Cap, 3 DE&C, 4 C&S) less partners

2.1.2 - Development Fee (Development Capital)

2.1.3 - Bus Develop Comm

2.1.4 - Investment Capital Fee

2.2 - Budget

2.3 - Actual Expense

2.4 - Financial Tracking

2.5 - Communications

 

[FenHow]

Yes, thank you. I am thinking it's something I am doing wrong. Thank you for all your help.

 

[Herakles]

Hi *FenHow

I've written it differently and a shorter version.

It also incorporates a check for forbidden characters in folder names.
You had a '/' in one folder name which caused by code to error.

All you have to do is change this line to indicate your base folder.
strBaseFolder = "C:\folders\"

Public Sub subCreateFolders()
Dim rngFolders  As Range
Dim intLevel As Integer
Dim arrFolders(1 To 100) As Variant
Dim strPath As String
Dim intRow As Integer
Dim rng As Range
Dim strBaseFolder As String
Dim i As Integer
Dim fdObj As Object
Dim intCount As Integer
Dim arrForbidden(1 To 9) As String

On Error GoTo Err_Handler

    arrForbidden(1) = "<"
    arrForbidden(2) = ">"
    arrForbidden(3) = ":"
    arrForbidden(4) = """"
    arrForbidden(5) = "/"
    arrForbidden(6) = "\"
    arrForbidden(7) = "|"
    arrForbidden(8) = "?"
    arrForbidden(9) = "*"

    Set fdObj = CreateObject("Scripting.FileSystemObject")
    
    strBaseFolder = "C:\folders\"
    If Not fdObj.FolderExists(strBaseFolder) Then
        MsgBox "Base folder, '" & strBaseFolder & "' does not exist.", vbCritical, "Warning!"
        Exit Sub
    End If
    
    Set rngFolders = Range("A1:A" & ActiveSheet.Cells(ActiveSheet.Rows.Count, "A").End(xlUp).Row)
            
    For Each rng In rngFolders.Cells
        
        ' Check for forbidden characters.
        For i = 1 To 9
            If InStr(1, rng.Value, arrForbidden(i), vbTextCompare) > 0 Then
                MsgBox "There is a forbidden character '" & arrForbidden(i) & "' in this folder name" _
                    & vbCrLf & vbCrLf & rng.Value, vbCritical, "Warning!"
                Exit Sub
            End If
        Next i
                
        intLevel = Len(rng.Value) - Len(Replace(rng.Value, ".", "", 1))
                
        arrFolders(intLevel) = rng.Value
        
        strPath = ""
                        
        For i = 1 To intLevel
            strPath = strPath & "\" & arrFolders(i)
        Next i
        
        If Not fdObj.FolderExists(strBaseFolder & strPath) Then
             fdObj.CreateFolder (strBaseFolder & "\" & strPath)
             intCount = intCount + 1
        End If
                        
    Next rng
    
    If intCount = 0 Then
        MsgBox "No new folders have been created.", vbInformation, "Confirmation."
    Else
        MsgBox intCount & " folders have been created.", vbInformation, "Confirmation."
    End If

Exit_Handler:

    Set fdObj = Nothing
    
    Exit Sub

Err_Handler:
                    
    MsgBox "There has been an error. Not all of the folders will have been created", vbCritical, "Warning!"
   
Resume Exit_Handler
    
End Sub

 

[FenHow]

Herakles, you are a rock star! well done! I cannot thank you enough. It works perfectly. If I could make one change it would be to nest the 1.1,1.2,1.3 etc in the 1.0 folder and the 2.1,2.2,2.3, in the 2.0 folder and so on. If not no problem. I sincerely appreciate your help on this one.
Fen

 

[Herakles]

This will sort the nesting problem out.

Warning - It only goes up to a 9.0 path prefix.
I'm working on it being able to go on to an infiniite number.

Columns B and C need to be available so put the folder list into a clean sheet.
The sheet with the list in needs to be the active sheet but a check is made.

The code turns calculation to automatic.

Change this line to indicate the base folder.
strBaseFolder = "C:\abcdef\"

Private Sub subCreateFoldersVersionThree()
Dim i As Integer
Dim ii As Integer
Dim iii As Integer
Dim varIndex As Variant
Dim arr() As String
Dim fdObj As Object
Dim strFormula As String
Dim Q As String
Dim strBaseFolder As String
Dim arrForbidden() As String
Dim strForbidden As String
Dim blnfail As Boolean
Dim strCreate As String
Dim strMsg As String
Dim rngFolders As Range
Dim intCount As Integer

On Error GoTo Err_Handler

    ActiveWorkbook.Save
    
    Application.Calculation = xlCalculationAutomatic
    
    If MsgBox("Are your folders in this worksheet?", vbYesNo, "Question") = vbNo Then
        Exit Sub
    End If

    Q = Chr(34)

    strForbidden = "< > : / \ ? | * " & Q
    
    arrForbidden = Split(strForbidden, " ")
     
    Set fdObj = CreateObject("Scripting.FileSystemObject")
        
    strBaseFolder = "C:\abcdef\"
    If Not fdObj.FolderExists(strBaseFolder) Then
        MsgBox "Base folder, '" & strBaseFolder & "' does not exist.", vbCritical, "Warning!"
        Exit Sub
    End If
        
    strFormula = "=SUBSTITUTE(LEFT(SUBSTITUTE($A1," & Q & ".0" & Q & "," & Q & Q & "),FIND(" & Q & " " & _
        Q & ",SUBSTITUTE($A1," & Q & ".0" & Q & "," & Q & Q & "),1)-1)," & Q & "." & Q & "," & Q & Q & ")"
    Range("A1").CurrentRegion.Columns(1).Offset(0, 1).Formula = strFormula
        
    Set rngFolders = Range("B1:B" & ActiveSheet.Cells(ActiveSheet.Rows.Count, "A").End(xlUp).Row)
        
    strFormula = "=(IF(LEN($B1)>1,MATCH(LEFT(SUBSTITUTE(LEFT($A1,FIND(" & Q & " " & Q & ",$A1,1)-1)," & Q & "." & Q & "," & Q & Q & ")," & _
        "LEN(SUBSTITUTE(LEFT($A1,FIND(" & Q & " " & Q & ",$A1,1)-1)," & Q & "." & Q & "," & Q & Q & "))-1)," & rngFolders.Address & ",0)," & Q & Q & "))"
    Range("A1").CurrentRegion.Columns(1).Offset(0, 2).Formula = strFormula
            
    arrFlds = Range("A1:C" & ActiveSheet.Cells(ActiveSheet.Rows.Count, "A").End(xlUp).Row)
        
    For i = LBound(arrFlds) To UBound(arrFlds)
        For iii = LBound(arrForbidden) To UBound(arrForbidden)
            If InStr(1, arrFlds(i, 1), arrForbidden(iii), vbTextCompare) > 0 Then
                strMsg = "This folder name has a '" & arrForbidden(iii) & "' invalid character in it."
                strMsg = strMsg & vbCrLf & vbCrLf & arrFlds(i, 1)
                MsgBox strMsg, vbCritical, "Warning!"
                Exit Sub
            End If
        Next iii
    Next i
        
    Range("A1").CurrentRegion.Columns(2).ClearContents
    Range("A1").CurrentRegion.Columns(3).ClearContents
    
    For i = UBound(arrFlds) To 1 Step -1
       
        strPath = arrFlds(i, 1)
        
        If arrFlds(i, 3) <> "" Then
            
            varIndex = arrFlds(i, 3)
            
            If varIndex <> "" Then
                Do While varIndex <> ""
                    strPath = arrFlds(varIndex, 1) & "\" & strPath
                    varIndex = arrFlds(varIndex, 3)
                Loop
            End If
                 
            arr = Split(strPath, "\")
            
            strPath = ""
            For ii = LBound(arr) To UBound(arr)
                strPath = strPath & "\" & arr(ii)
                strCreate = Replace(strBaseFolder & strPath, "\\", "\", 1)
                If Not fdObj.FolderExists(strCreate) Then
                    fdObj.CreateFolder (strCreate)
                    intCount = intCount + 1
                End If
            Next ii
                              
        End If
        
    Next i
    
    strCreate = ""
    
    If intCount = 0 Then
        strMsg = "No folders have been created."
        strMsg = strMsg & vbCrLf & "This may be because they already existed."
    Else
        strMsg = intCount & " folders have been created."
    End If
    
    MsgBox strMsg, vbInformation, "Confirmation."
        
Exit_Handler:

    Set fdObj = Nothing
    
    Exit Sub

Err_Handler:
        
    MsgBox "There has been an error. Not all of the folders will have been created", vbCritical, "Warning!"
    
    MsgBox "The problem may be with the following path." & vbCrLf & strCreate, vbInformation, "Information"
    
    Resume Exit_Handler
    
End Sub