Folder structure creator - Excel VBS

If you need to create a lot of folders and subfolders, with some specific structure, it can be usefull if you can use the power of Excel to make up your folder names and structure. All kind of easy and quick formulas can be used, and once the strucuture is set up, you can easily create the empty folder structure with just one click by using this little VBS macro. The base folder used will depend on the location of the Excel file, so make sure it's saved or copied in the correct folder.

Sub CreateFolderStructure()
'Create folder for all vlues in current sheet
'folders will be created in folder where the excel file was saved
'folders will be created from first row, first column, until empty row is found
'Example expected cell structure: (data starting in current sheet, column A, row 1)
'folder1 subfolder1 subsubfolder1
'folder2
'folder3 subfolder3
'...
'this will result in:
'\folder1\subfolder1\subsubfolder1
'\folder2
'\folder3\subfolder3
'...
Set fs = CreateObject("Scripting.FileSystemObject")
For iRow = 1 To 65000
pathToCreate = ActiveWorkbook.Path
For iColumn = 1 To 65000
currValue = Worksheets(ActiveCell.Worksheet.Name).Cells(iRow, iColumn).Value
If (currValue = "") Then
Exit For
Else
pathToCreate = pathToCreate & "\" & CStr(currValue)
'MsgBox (pathToCreate)
folderToCreate = pathToCreate
If Not (fs.FolderExists(folderToCreate)) Then
fs.CreateFolder (folderToCreate)
End If
End If
Next
Next
End Sub

The Excel sheet with the macro can be downloaded here. Before running the macro make sure the rows and columns of the active sheet are filled in correctly. Next simply run the macro by using the button.


If you created to many empty folders by accident, you can easily remove them again using this little tool: Remove Empty Directories


Update 13/11/2009: Modified the Excel VBS script to let you navigate to the desired base folder upon launching the macro, so the Excel file may now be saved at any location, the base folder will have to be specified upon launching the macro.


Update 21/04/2012: Someone commented the VBS code is not working correctly when using some special characters. This is because some characters are not supported by Windows to be used in a file or folder name.





I updated the VBS code in the Excel sheet to make sure these special characters are removed before trying to create the folders.


The Excel sheet is updated, also an Excel template is available.


An example with special characters and the resulting folders created:





The new VBS code used is:

Sub CreateFolderStructure()
'Create folder for all vlues in current sheet
'folders will be created in folder where the excel file was saved
'folders will be created from first row, first column, until empty row is found
'Example expected cell structure: (data starting in current sheet, column A, row 1)
'folder1    subfolder1  subsubfolder1
'folder2
'folder3    subfolder3
'           subfolder4
'...
'this will result in:
'\folder1\subfolder1\subsubfolder1
'\folder2
'\folder3\subfolder3
'\folder3\subfolder4
'...
    baseFolder = BrowseForFolder
    If (baseFolder = False) Then
        Exit Sub
    End If
    Set fs = CreateObject("Scripting.FileSystemObject")
    For iRow = 2 To 6500
        pathToCreate = baseFolder
        leafFound = False
        For iColumn = 1 To 6500
            currValue = Trim(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Worksheets(ActiveCell.Worksheet.Name).Cells(iRow, iColumn).Value, ":", ""), "*", ""), "?", ""), Chr(34), ""), "<", ""), ">", ""), "|", ""))
            If (currValue = "" And leafFound) Then
                Exit For
            ElseIf (currValue = "") Then
                parentFolder = FindParentFolder(iRow, iColumn)
                parentFolder = Replace(Replace(Replace(Replace(Replace(Replace(Replace(parentFolder, ":", ""), "*", ""), "?", ""), Chr(34), ""), "<", ""), ">", ""), "|", "")
                If (parentFolder = False) Then
                    Exit For
                Else
                    pathToCreate = pathToCreate & "\" & parentFolder
                    If Not (fs.FolderExists(pathToCreate)) Then
                        CreateDirs (pathToCreate)
                    End If
                End If
            Else
                leafFound = True
                pathToCreate = pathToCreate & "\" & currValue
                If Not (fs.FolderExists(pathToCreate)) Then
                    CreateDirs (pathToCreate)
                End If
            End If
        Next
        If (leafFound = False) Then
            Exit For
        End If
    Next
End Sub

Function FindParentFolder(row, column)
    For iRow = row To 0 Step -1
        currValue = Worksheets(ActiveCell.Worksheet.Name).Cells(iRow, column).Value
        If (currValue <> "") Then
            FindParentFolder = CStr(currValue)
            Exit Function
        ElseIf (column <> 1) Then
            leftValue = Worksheets(ActiveCell.Worksheet.Name).Cells(iRow, column - 1).Value
            If (leftValue <> "") Then
                FindParentFolder = False
                Exit Function
            End If
        End If
    Next
End Function


Function BrowseForFolder(Optional OpenAt As Variant) As Variant
     'Function purpose:  To Browser for a user selected folder.
     'If the "OpenAt" path is provided, open the browser at that directory
     'NOTE:  If invalid, it will open at the Desktop level
     
    Dim ShellApp As Object
     
     'Create a file browser window at the default folder
    Set ShellApp = CreateObject("Shell.Application"). _
    BrowseForFolder(0, "Please choose a folder", 0, OpenAt)
     'Set the folder to that selected.  (On error in case cancelled)
    On Error Resume Next
    BrowseForFolder = ShellApp.self.Path
    On Error GoTo 0
     
     'Destroy the Shell Application
    Set ShellApp = Nothing
     
     'Check for invalid or non-entries and send to the Invalid error
     'handler if found
     'Valid selections can begin L: (where L is a letter) or
     '\\ (as in \\servername\sharename.  All others are invalid
    Select Case Mid(BrowseForFolder, 2, 1)
    Case Is = ":"
        If Left(BrowseForFolder, 1) = ":" Then GoTo Invalid
    Case Is = "\"
        If Not Left(BrowseForFolder, 1) = "\" Then GoTo Invalid
    Case Else
        GoTo Invalid
    End Select
     
    Exit Function
     
Invalid:
     'If it was determined that the selection was invalid, set to False
    BrowseForFolder = False
     
End Function

Sub CreateDirs(MyDirName)
' This subroutine creates multiple folders like CMD.EXE's internal MD command.
' By default VBScript can only create one level of folders at a time (blows
' up otherwise!).
'
' Argument:
' MyDirName   [string]   folder(s) to be created, single or
'                        multi level, absolute or relative,
'                        "d:\folder\subfolder" format or UNC
'
' Written by Todd Reeves
' Modified by Rob van der Woude
' http://www.robvanderwoude.com

    Dim arrDirs, i, idxFirst, objFSO, strDir, strDirBuild

    ' Create a file system object
    Set objFSO = CreateObject("Scripting.FileSystemObject")

    ' Convert relative to absolute path
    strDir = objFSO.GetAbsolutePathName(MyDirName)

    ' Split a multi level path in its "components"
    arrDirs = Split(strDir, "\")

    ' Check if the absolute path is UNC or not
    If Left(strDir, 2) = "\\" Then
        strDirBuild = "\\" & arrDirs(2) & "\" & arrDirs(3) & "\"
        idxFirst = 4
    Else
        strDirBuild = arrDirs(0) & "\"
        idxFirst = 1
    End If

    ' Check each (sub)folder and create it if it doesn't exist
    For i = idxFirst To UBound(arrDirs)
        strDirBuild = objFSO.BuildPath(strDirBuild, arrDirs(i))
        If Not objFSO.FolderExists(strDirBuild) Then
            objFSO.CreateFolder strDirBuild
        End If
    Next

    ' Release the file system object
    Set objFSO = Nothing
End Sub

11/10/2012: I updated the VBS code in the Excel sheet to make sure these special characters are removed before trying to create the folders. Extra input information and validation is added to make sure invalid characters can not be used. The Excel sheet is updated


08/08/2013: Updated sheets, added a trim to remove spaces at begin and end of cell value, since this could result in macro exception (see comments)


17/02/2014: I’ve extended this workbook with a new sheet in which the nested folder structure of the filesystem can be imported. Each folder name will be stored in a separate cell respecting the nested structure


The new VBS code is:

  
Sub ImportFolderStructure()
'Import folder structure starting from selected base folder
'each subfolder will be stored in a separete cell
'eg:
'Folder 1|Subfolder1|SubSubfolder1
'Folder 2|Subfolder2
'Folder 3|Subfolder3|SubSubfolder3
'...
    Application.ScreenUpdating = False
    baseFolder = BrowseForFolder
    If (baseFolder = False) Then
        Exit Sub
    End If
    Application.StatusBar = "Folder structure below " & baseFolder & " will be stored in the sheet " & ActiveCell.Worksheet.Name
    StoreSubFolder baseFolder, 1, 0
    Application.StatusBar = "Folder structure below " & baseFolder & " has been stored in the sheet " & ActiveCell.Worksheet.Name
    Range("A2").Select
    Application.ScreenUpdating = True
End Sub

Sub StoreSubFolder(baseFolderObj, ByRef iRow, ByVal iColumn)
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set folderBase = fs.GetFolder(baseFolderObj)
    Set folderBaseSubs = folderBase.SubFolders
    iRow = iRow + 1
    iColumn = iColumn + 1
    For Each subFolder In folderBaseSubs
        Worksheets(ActiveCell.Worksheet.Name).Cells(iRow, iColumn).Value = subFolder.Name
        StoreSubFolder subFolder, iRow, iColumn
    Next
End Sub

Sub ClearImportData()
    Application.ScreenUpdating = False
    Range("A2").Select
    Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
    Selection.ClearContents
    Range("A2").Select
    Application.ScreenUpdating = True
End Sub

Sub CreateFolderStructure()
'Create folder for all vlues in current sheet
'folders will be created in folder where the excel file was saved
'folders will be created from first row, first column, until empty row is found
'Example expected cell structure: (data starting in current sheet, column A, row 1)
'folder1    subfolder1  subsubfolder1
'folder2
'folder3    subfolder3
'           subfolder4
'...
'this will result in:
'<currentpath>\folder1\subfolder1\subsubfolder1
'<currentpath>\folder2
'<currentpath>\folder3\subfolder3
'<currentpath>\folder3\subfolder4
'...
    baseFolder = BrowseForFolder
    If (baseFolder = False) Then
        Exit Sub
    End If
    Set fs = CreateObject("Scripting.FileSystemObject")
    For iRow = 2 To 6500
        pathToCreate = baseFolder
        leafFound = False
        For iColumn = 1 To 6500
            currValue = Trim(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Worksheets(ActiveCell.Worksheet.Name).Cells(iRow, iColumn).Value, ":", "-"), "*", "-"), "?", "-"), Chr(34), "-"), "<", "-"), ">", "-"), "|", "-"), "/", "-"), "\", "-"))
            Worksheets(ActiveCell.Worksheet.Name).Cells(iRow, iColumn).Value = currValue
            If (currValue = "" And leafFound) Then
                Exit For
            ElseIf (currValue = "") Then
                parentFolder = FindParentFolder(iRow, iColumn)
                If (parentFolder = False) Then
                    Exit For
                Else
                    pathToCreate = pathToCreate & "\" & parentFolder
                    If Not (fs.FolderExists(pathToCreate)) Then
                        CreateDirs (pathToCreate)
                    End If
                End If
            Else
                leafFound = True
                pathToCreate = pathToCreate & "\" & currValue
                If Not (fs.FolderExists(pathToCreate)) Then
                    CreateDirs (pathToCreate)
                End If
            End If
        Next
        If (leafFound = False) Then
            Exit For
        End If
    Next
End Sub

Function FindParentFolder(row, column)
    For iRow = row To 0 Step -1
        currValue = Worksheets(ActiveCell.Worksheet.Name).Cells(iRow, column).Value
        If (currValue <> "") Then
            FindParentFolder = CStr(currValue)
            Exit Function
        ElseIf (column <> 1) Then
            leftValue = Worksheets(ActiveCell.Worksheet.Name).Cells(iRow, column - 1).Value
            If (leftValue <> "") Then
                FindParentFolder = False
                Exit Function
            End If
        End If
    Next
End Function

Function BrowseForFolder(Optional OpenAt As Variant) As Variant
     'Function purpose:  To Browser for a user selected folder.
     'If the "OpenAt" path is provided, open the browser at that directory
     'NOTE:  If invalid, it will open at the Desktop level
     
    Dim ShellApp As Object
     
     'Create a file browser window at the default folder
    Set ShellApp = CreateObject("Shell.Application"). _
    BrowseForFolder(0, "Please choose a folder", 0, OpenAt)
     'Set the folder to that selected.  (On error in case cancelled)
    On Error Resume Next
    BrowseForFolder = ShellApp.self.Path
    On Error GoTo 0
     
     'Destroy the Shell Application
    Set ShellApp = Nothing
     
     'Check for invalid or non-entries and send to the Invalid error
     'handler if found
     'Valid selections can begin L: (where L is a letter) or
     '\\ (as in \\servername\sharename.  All others are invalid
    Select Case Mid(BrowseForFolder, 2, 1)
    Case Is = ":"
        If Left(BrowseForFolder, 1) = ":" Then GoTo Invalid
    Case Is = "\"
        If Not Left(BrowseForFolder, 1) = "\" Then GoTo Invalid
    Case Else
        GoTo Invalid
    End Select
     
    Exit Function
     
Invalid:
     'If it was determined that the selection was invalid, set to False
    BrowseForFolder = False
     
End Function

Sub CreateDirs(MyDirName)
' This subroutine creates multiple folders like CMD.EXE's internal MD command.
' By default VBScript can only create one level of folders at a time (blows
' up otherwise!).
'
' Argument:
' MyDirName   [string]   folder(s) to be created, single or
'                        multi level, absolute or relative,
'                        "d:\folder\subfolder" format or UNC
'
' Written by Todd Reeves
' Modified by Rob van der Woude
' http://www.robvanderwoude.com

    Dim arrDirs, i, idxFirst, objFSO, strDir, strDirBuild
    ' Create a file system object
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    ' Convert relative to absolute path
    strDir = objFSO.GetAbsolutePathName(MyDirName)
    ' Split a multi level path in its "components"
    arrDirs = Split(strDir, "\")
    ' Check if the absolute path is UNC or not
    If Left(strDir, 2) = "\\" Then
        strDirBuild = "\\" & arrDirs(2) & "\" & arrDirs(3) & "\"
        idxFirst = 4
    Else
        strDirBuild = arrDirs(0) & "\"
        idxFirst = 1
    End If

    ' Check each (sub)folder and create it if it doesn't exist
    For i = idxFirst To UBound(arrDirs)
        strDirBuild = objFSO.BuildPath(strDirBuild, arrDirs(i))
        If Not objFSO.FolderExists(strDirBuild) Then
            objFSO.CreateFolder strDirBuild
        End If
    Next

    ' Release the file system object
    Set objFSO = Nothing
End Sub

The Excel file can be downloaded as XLS (template for easy reuse). My Excel sheet with combined macro’s has been updated as well, see this blog post.










Update 27/05/2014: cleanup of the cell types (some cell were saved as type ‘Scientific’ resulting in some strange representation after import of folders named with numbers, Thanks to Jean for reporting)