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)
Posts
