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]

Welcome to Mr Excel.

This will create a folder structure based upon your list.

The code in the 'subRun' procedure is the only code that you need to amend as appropriate.
It is the 'subRun' procedure that you need to run.

You need to specify the range of cells where your folder list is on the following line:
Set rngFolders = Range("A1:A" & ActiveSheet.Cells(ActiveSheet.Rows.Count, "A").End(xlUp).Row)
(Do not include a column header.)

You also need to specify the drive and base folder on the following line:
strBaseFolder = "C:\CreateFolders"

If the base folder does not exist then it is created.

You can use this code to add to an already existing folder structure in exactly the same way.
Existing folders will not be deleted.

The 1.1.3.2 nomenclature is essential as it dictates the level of the folders in the structure. The level is indicated by the
number of periods in this string plus two.

Private Sub subRun()
Dim rngFolders  As Range
Dim strBaseFolder As String
Dim strMsg As String

    ActiveWorkbook.Save
    
    ' Range containing the list of folders.
    Set rngFolders = Range("A1:A" & ActiveSheet.Cells(ActiveSheet.Rows.Count, "A").End(xlUp).Row)
    
    ' This is the folder within which all other folders are created."
    strBaseFolder = "C:\CreateFolders"
    
    ' Call to the procedure to create folders.
    Call subCreateFolderStructure(rngFolders, strBaseFolder)
     
    MsgBox "Finished creating folders.", vbInformation, "Confirmation"
    
End Sub

Public Sub subCreateFolderStructure(rngFolders As Range, strBaseFolder As String)
Dim arrFolders() As Variant
Dim i As Integer
Dim arrSplit() As String
Dim intLevel As Integer
Dim intPrevLevel  As Integer
Dim strPath As String
Dim strFolder As String

    If Right(strBaseFolder, 1) = "\" Then
        strBaseFolder = Left(strBaseFolder, Len(strBaseFolder) - 1)
    End If
        
    arrFolders = rngFolders
                
    strPath = strBaseFolder
    
    For i = LBound(arrFolders) To UBound(arrFolders)
        arrSplit = Split(arrFolders(i, 1), " ")
        intLevel = (Len(Replace(arrSplit(0), ".0", "", 1)) - Len(Replace(Replace(arrSplit(0), ".0", "", 1), ".", "", 1))) + 1
        strFolder = Trim(Replace(arrFolders(i, 1), ".", ".", 1))
        If intLevel < intPrevLevel Then
            strPath = fncRemoveLevels(strPath, "\", intLevel)
        End If
        strPath = strPath & "\" & strFolder
        intPrevLevel = intLevel
        Call subCreateFolderPath(Left(strBaseFolder, 2), strPath)
    Next i
                
End Sub

Public Function fncRemoveLevels(strString As String, strDelimiter As String, intLevel As Integer) As String
Dim i As Integer
Dim arrPath() As String
Dim strResult As String

    If Right(strString, 1) <> strDelimiter Then
        strString = strString & "\"
    End If

    arrPath = Split(strString, strDelimiter)
    
    For i = 0 To intLevel
        strResult = strResult & "\" & arrPath(i)
    Next i

    fncRemoveLevels = Mid(strResult, 2, Len(strResult) - 1)

End Function

Public Sub subCreateFolderPath(strDrive As String, strPath As String)
Dim arrPath() As String
Dim i As Integer
Dim strFolder As String
Dim fdObj As Object

    Set fdObj = CreateObject("Scripting.FileSystemObject")

    arrPath = Split(strPath, "\")
        
    On Error Resume Next
    
    For i = LBound(arrPath) + 1 To UBound(arrPath)
        strFolder = strFolder & "\" & arrPath(i)
        If Not fdObj.FolderExists(strFolder) Then
            fdObj.CreateFolder (strFolder)
        End If
    Next i
    
    On Error GoTo 0
    
    Set fdObj = Nothing

End Sub

 

[Herakles]

Welcome to Mr Excel.

This will create a folder structure based upon your list.

The code in the 'subRun' procedure is the only code that you need to amend as appropriate.
It is the 'subRun' procedure that you need to run.

You need to specify the range of cells where your folder list is on the following line:
Set rngFolders = Range("A1:A" & ActiveSheet.Cells(ActiveSheet.Rows.Count, "A").End(xlUp).Row)
(Do not include a column header.)

You also need to specify the drive and base folder on the following line:
strBaseFolder = "C:\CreateFolders"

If the base folder does not exist then it is created.

You can use this code to add to an already existing folder structure in exactly the same way.
Existing folders will not be deleted.

The 1.1.3.2 nomenclature is essential as it dictates the level of the folders in the structure. The level is indicated by the
number of periods in this string plus two.

Private Sub subRun()
Dim rngFolders  As Range
Dim strBaseFolder As String
Dim strMsg As String

    ActiveWorkbook.Save
   
    ' Range containing the list of folders.
    Set rngFolders = Range("A1:A" & ActiveSheet.Cells(ActiveSheet.Rows.Count, "A").End(xlUp).Row)
   
    ' This is the folder within which all other folders are created."
    strBaseFolder = "C:\CreateFolders"
   
    ' Call to the procedure to create folders.
    Call subCreateFolderStructure(rngFolders, strBaseFolder)
    
    MsgBox "Finished creating folders.", vbInformation, "Confirmation"
   
End Sub

Public Sub subCreateFolderStructure(rngFolders As Range, strBaseFolder As String)
Dim arrFolders() As Variant
Dim i As Integer
Dim arrSplit() As String
Dim intLevel As Integer
Dim intPrevLevel  As Integer
Dim strPath As String
Dim strFolder As String

    If Right(strBaseFolder, 1) = "\" Then
        strBaseFolder = Left(strBaseFolder, Len(strBaseFolder) - 1)
    End If
       
    arrFolders = rngFolders
               
    strPath = strBaseFolder
   
    For i = LBound(arrFolders) To UBound(arrFolders)
        arrSplit = Split(arrFolders(i, 1), " ")
        intLevel = (Len(Replace(arrSplit(0), ".0", "", 1)) - Len(Replace(Replace(arrSplit(0), ".0", "", 1), ".", "", 1))) + 1
        strFolder = Trim(Replace(arrFolders(i, 1), ".", ".", 1))
        If intLevel < intPrevLevel Then
            strPath = fncRemoveLevels(strPath, "\", intLevel)
        End If
        strPath = strPath & "\" & strFolder
        intPrevLevel = intLevel
        Call subCreateFolderPath(Left(strBaseFolder, 2), strPath)
    Next i
               
End Sub

Public Function fncRemoveLevels(strString As String, strDelimiter As String, intLevel As Integer) As String
Dim i As Integer
Dim arrPath() As String
Dim strResult As String

    If Right(strString, 1) <> strDelimiter Then
        strString = strString & "\"
    End If

    arrPath = Split(strString, strDelimiter)
   
    For i = 0 To intLevel
        strResult = strResult & "\" & arrPath(i)
    Next i

    fncRemoveLevels = Mid(strResult, 2, Len(strResult) - 1)

End Function

Public Sub subCreateFolderPath(strDrive As String, strPath As String)
Dim arrPath() As String
Dim i As Integer
Dim strFolder As String
Dim fdObj As Object

    Set fdObj = CreateObject("Scripting.FileSystemObject")

    arrPath = Split(strPath, "\")
       
    On Error Resume Next
   
    For i = LBound(arrPath) + 1 To UBound(arrPath)
        strFolder = strFolder & "\" & arrPath(i)
        If Not fdObj.FolderExists(strFolder) Then
            fdObj.CreateFolder (strFolder)
        End If
    Next i
   
    On Error GoTo 0
   
    Set fdObj = Nothing

End Sub

I've just realised that you have some long paths and Windows has a 256 character limit for a path. Don't use the code that I have posted and I'll amend it to create a check on folder lengths.

Are you able to keep the path length to less than 256 characters? This will need to include the length of the folder within which you are building your folder structure.

 

[FenHow]

Hi, thank you so much for the help. This gives me great hope that this will actually work.
I can definitely control the length of the folder names. So, do I just use your code exclusively and remove the one I showed in my original thread?
Can you upload a mini-sheet example as well? That would be AWESOME! thanks again for you time.
Fen

 

[FenHow]

Also, I tried to run the code and was stopped here. Any idea why? I don't know what this means.
Thanks
Fen

 

[Herakles]

Is the worksheet with the folder names in it the active worksheet?

Does the rngFolders range point to the correct cells?

 

[FenHow]

Yes I am running a test on the code A1:A24 active sheet.

ActiveWorkbook.Save

' Range containing the list of folders.
Set rngFolders = Range("A1:A24" & ActiveSheet.Cells(ActiveSheet.Rows.Count, "A").End(xlUp).Row)

' This is the folder within which all other folders are created."
strBaseFolder = "C:\CreateFolders"

' Call to the procedure to create folders.
Call subCreateFolderStructure(rngFolders, strBaseFolder)

MsgBox "Finished creating folders.", vbInformation, "Confirmation"

 

[FenHow]

Can I send you the workbook? If so how?
Thank you again.

 

[Herakles]

No need for that.

Change this line:
Set rngFolders = Range("A1:A24" & ActiveSheet.Cells(ActiveSheet.Rows.Count, "A").End(xlUp).Row)

to
Set rngFolders = Range("A1:A24") ' & ActiveSheet.Cells(ActiveSheet.Rows.Count, "A").End(xlUp).Row)

 

[FenHow]

Ok getting closer, it runs to this point then I get a subscript out of range. also attached is my excel list, will the words affect the code from running?
Thanks again.
Fen