Create a folder and sub folder in Excel VBA

I have a pull down menu of companies that is populated by a list on another sheet. Three columns, Company, Job #, and Part Number.

When a job is created I need a folder for said company and a sub-folder for said Part Number.

If you go down the path it would look like:

C:\Images\Company Name\Part Number\

If either company name or Part number exists don't create, or overwrite the old one. Just go to next step. So if both folders exist nothing happens, if one or both don't exist create as required.

Another question is there a way to make it so it works on Macs and PCs the same?

14 Answers

Another simple version working on PC:

Sub CreateDir(strPath As String) Dim elm As Variant Dim strCheckPath As String strCheckPath = "" For Each elm In Split(strPath, "\") strCheckPath = strCheckPath & elm & "\" If Len(Dir(strCheckPath, vbDirectory)) = 0 Then MkDir strCheckPath Next End Sub 

One sub and two functions. The sub builds your path and use the functions to check if the path exists and create if not. If the full path exists already, it will just pass on by. This will work on PC, but you will have to check what needs to be modified to work on Mac as well.

'requires reference to Microsoft Scripting Runtime Sub MakeFolder() Dim strComp As String, strPart As String, strPath As String strComp = Range("A1") ' assumes company name in A1 strPart = CleanName(Range("C1")) ' assumes part in C1 strPath = "C:\Images\" If Not FolderExists(strPath & strComp) Then 'company doesn't exist, so create full path FolderCreate strPath & strComp & "\" & strPart Else 'company does exist, but does part folder If Not FolderExists(strPath & strComp & "\" & strPart) Then FolderCreate strPath & strComp & "\" & strPart End If End If End Sub Function FolderCreate(ByVal path As String) As Boolean FolderCreate = True Dim fso As New FileSystemObject If Functions.FolderExists(path) Then Exit Function Else On Error GoTo DeadInTheWater fso.CreateFolder path ' could there be any error with this, like if the path is really screwed up? Exit Function End If DeadInTheWater: MsgBox "A folder could not be created for the following path: " & path & ". Check the path name and try again." FolderCreate = False Exit Function End Function Function FolderExists(ByVal path As String) As Boolean FolderExists = False Dim fso As New FileSystemObject If fso.FolderExists(path) Then FolderExists = True End Function Function CleanName(strName as String) as String 'will clean part # name so it can be made into valid folder name 'may need to add more lines to get rid of other characters CleanName = Replace(strName, "/","") CleanName = Replace(CleanName, "*","") etc... End Function 

I found a much better way of doing the same, less code, much more efficient. Note that the """" is to quote the path in case it contains blanks in a folder name. Command line mkdir creates any intermediary folder if necessary to make the whole path exist.

If Dir(YourPath, vbDirectory) = "" Then Shell ("cmd /c mkdir """ & YourPath & """") End If 

Private Sub CommandButton1_Click() Dim fso As Object Dim fldrname As String Dim fldrpath As String Set fso = CreateObject("scripting.filesystemobject") fldrname = Format(Now(), "dd-mm-yyyy") fldrpath = "C:\Temp\" & fldrname If Not fso.FolderExists(fldrpath) Then fso.createfolder (fldrpath) End If End Sub 

There are some good answers on here, so I will just add some process improvements. A better way of determining if the folder exists (does not use FileSystemObjects, which not all computers are allowed to use):

Function FolderExists(FolderPath As String) As Boolean FolderExists = True On Error Resume Next ChDir FolderPath If Err <> 0 Then FolderExists = False On Error GoTo 0 End Function 

Likewise,

Function FileExists(FileName As String) As Boolean If Dir(FileName) <> "" Then FileExists = True Else FileExists = False EndFunction 

Function MkDir(ByVal strDir As String) Dim fso: Set fso = CreateObject("Scripting.FileSystemObject") If Not fso.FolderExists(strDir) Then ' create parent folder if not exist (recursive) MkDir (fso.GetParentFolderName(strDir)) ' doesn't exist, so create the folder fso.CreateFolder strDir End If End Function 

This works like a charm in AutoCad VBA and I grabbed it from an excel forum. I don't know why you all make it so complicated?

FREQUENTLY ASKED QUESTIONS

Question: I'm not sure if a particular directory exists already. If it doesn't exist, I'd like to create it using VBA code. How can I do this?

Answer: You can test to see if a directory exists using the VBA code below:

(Quotes below are omitted to avoid confusion of programming code)

If Len(Dir("c:\TOTN\Excel\Examples", vbDirectory)) = 0 Then MkDir "c:\TOTN\Excel\Examples" End If 

For those looking for a cross-platform way that works on both Windows and Mac, the following works:

Sub CreateDir(strPath As String) Dim elm As Variant Dim strCheckPath As String strCheckPath = "" For Each elm In Split(strPath, Application.PathSeparator) strCheckPath = strCheckPath & elm & Application.PathSeparator If (Len(strCheckPath) > 1 And Not FolderExists(strCheckPath)) Then MkDir strCheckPath End If Next End Sub Function FolderExists(FolderPath As String) As Boolean FolderExists = True On Error Resume Next ChDir FolderPath If Err <> 0 Then FolderExists = False On Error GoTo 0 End Function 

Never tried with non Windows systems, but here's the one I have in my library, pretty easy to use. No special library reference required.

Function CreateFolder(ByVal sPath As String) As Boolean 'by Patrick Honorez - 'create full sPath at once, if required 'returns False if folder does not exist and could NOT be created, True otherwise 'sample usage: If CreateFolder("C:\toto\test\test") Then debug.print "OK" 'updated 20130422 to handle UNC paths correctly ("\\MyServer\MyShare\MyFolder") Dim fs As Object Dim FolderArray Dim Folder As String, i As Integer, sShare As String If Right(sPath, 1) = "\" Then sPath = Left(sPath, Len(sPath) - 1) Set fs = CreateObject("Scripting.FileSystemObject") 'UNC path ? change 3 "\" into 3 "@" If sPath Like "\\*\*" Then sPath = Replace(sPath, "\", "@", 1, 3) End If 'now split FolderArray = Split(sPath, "\") 'then set back the @ into \ in item 0 of array FolderArray(0) = Replace(FolderArray(0), "@", "\", 1, 3) On Error GoTo hell 'start from root to end, creating what needs to be For i = 0 To UBound(FolderArray) Step 1 Folder = Folder & FolderArray(i) & "\" If Not fs.FolderExists(Folder) Then fs.CreateFolder (Folder) End If Next CreateFolder = True hell: End Function 

Here's short sub without error handling that creates subdirectories:

Public Function CreateSubDirs(ByVal vstrPath As String) Dim marrPath() As String Dim mint As Integer marrPath = Split(vstrPath, "\") vstrPath = marrPath(0) & "\" For mint = 1 To UBound(marrPath) 'walk down directory tree until not exists If (Dir(vstrPath, vbDirectory) = "") Then Exit For vstrPath = vstrPath & marrPath(mint) & "\" Next mint MkDir vstrPath For mint = mint To UBound(marrPath) 'create directories vstrPath = vstrPath & marrPath(mint) & "\" MkDir vstrPath Next mint End Function 

I know this has been answered and there were many good answers already, but for people who come here and look for a solution I could post what I have settled with eventually.

The following code handles both paths to a drive (like "C:\Users...") and to a server address (style: "\Server\Path.."), it takes a path as an argument and automatically strips any file names from it (use "\" at the end if it's already a directory path) and it returns false if for whatever reason the folder could not be created. Oh yes, it also creates sub-sub-sub-directories, if this was requested.

Public Function CreatePathTo(path As String) As Boolean Dim sect() As String ' path sections Dim reserve As Integer ' number of path sections that should be left untouched Dim cPath As String ' temp path Dim pos As Integer ' position in path Dim lastDir As Integer ' the last valid path length Dim i As Integer ' loop var ' unless it all works fine, assume it didn't work: CreatePathTo = False ' trim any file name and the trailing path separator at the end: path = Left(path, InStrRev(path, Application.PathSeparator) - 1) ' split the path into directory names sect = Split(path, "\") ' what kind of path is it? If (UBound(sect) < 2) Then ' illegal path Exit Function ElseIf (InStr(sect(0), ":") = 2) Then reserve = 0 ' only drive name is reserved ElseIf (sect(0) = vbNullString) And (sect(1) = vbNullString) Then reserve = 2 ' server-path - reserve "\\Server\" Else ' unknown type Exit Function End If ' check backwards from where the path is missing: lastDir = -1 For pos = UBound(sect) To reserve Step -1 ' build the path: cPath = vbNullString For i = 0 To pos cPath = cPath & sect(i) & Application.PathSeparator Next ' i ' check if this path exists: If (Dir(cPath, vbDirectory) <> vbNullString) Then lastDir = pos Exit For End If Next ' pos ' create subdirectories from that point onwards: On Error GoTo Error01 For pos = lastDir + 1 To UBound(sect) ' build the path: cPath = vbNullString For i = 0 To pos cPath = cPath & sect(i) & Application.PathSeparator Next ' i ' create the directory: MkDir cPath Next ' pos CreatePathTo = True Exit Function Error01: End Function 

I hope someone may find this useful. Enjoy! :-)

This is a recursive version that works with letter drives as well as UNC. I used the error catching to implement it but if anyone can do one without, I would be interested to see it. This approach works from the branches to the root so it will be somewhat usable when you don't have permissions in the root and lower parts of the directory tree.

' Reverse create directory path. This will create the directory tree from the top down to the root. ' Useful when working on network drives where you may not have access to the directories close to the root Sub RevCreateDir(strCheckPath As String) On Error GoTo goUpOneDir: If Len(Dir(strCheckPath, vbDirectory)) = 0 And Len(strCheckPath) > 2 Then MkDir strCheckPath End If Exit Sub ' Only go up the tree if error code Path not found (76). goUpOneDir: If Err.Number = 76 Then Call RevCreateDir(Left(strCheckPath, InStrRev(strCheckPath, "\") - 1)) Call RevCreateDir(strCheckPath) End If End Sub 

Sub FolderCreate() MkDir "C:\Test" End Sub 

Sub MakeAllPath(ByVal PS$) Dim PP$ If PS <> "" Then ' chop any end name PP = Left(PS, InStrRev(PS, "\") - 1) ' if not there so build it If Dir(PP, vbDirectory) = "" Then MakeAllPath Left(PP, InStrRev(PS, "\") - 1) ' if not back to drive then build on what is there If Right(PP, 1) <> ":" Then MkDir PP End If End If End Sub 'Martins loop version above is better than MY recursive version 'so improve to below Sub MakeAllDir(PathS$) ' format "K:\firstfold\secf\fold3" If Dir(PathS) = vbNullString Then ' else do not bother Dim LI&, MYPath$, BuildPath$, PathStrArray$() PathStrArray = Split(PathS, "\") BuildPath = PathStrArray(0) & "\" ' If Dir(BuildPath) = vbNullString Then ' trap problem of no drive :\ path given If vbYes = MsgBox(PathStrArray(0) & "< not there for >" & PathS & " try to append to " & CurDir, vbYesNo) Then BuildPath = CurDir & "\" Else Exit Sub End If End If ' ' loop through required folders ' For LI = 1 To UBound(PathStrArray) BuildPath = BuildPath & PathStrArray(LI) & "\" If Dir(BuildPath, vbDirectory) = vbNullString Then MkDir BuildPath Next LI End If ' was already there End Sub ' use like 'MakeAllDir "K:\bil\joan\Johno" 'MakeAllDir "K:\bil\joan\Fredso" 'MakeAllDir "K:\bil\tom\wattom" 'MakeAllDir "K:\bil\herb\watherb" 'MakeAllDir "K:\bil\herb\Jim" 'MakeAllDir "bil\joan\wat" ' default drive