Text Functions‎ > ‎

Make Folders

PROBLEM:
"I'd like an easy way to create folders that I have listed in an Excel spreadsheet, have them get created all at once for me."

SPECIFICATIONS:
  1. No need to list directories and subdirectories separately, listing the deepest subdirectory will create all parent directories as needed
  2. Blank cells ignored in column used (column A)
  3. Works whether the final "\" is included in the list strings or not
EXAMPLE:
C:\2011\Test\
C:\2012\Test
C:\2013\Test\DeepTest\
C:\2014\Test\DeeperTest\DeeperStill

Based on the list above, this macro will create 11 directories.

Sample File:    MakeDirectories.xls

CODE

Option Explicit

Sub MakeDirectories()
'Author:    Jerry Beaucaire
'Date:      7/11/2010
'Summary:   Create directories and subdirectories based
'           on the text strings listed in column A
'           Parses parent directories too, no need to list separately
'           10/19/2010 - International compliant

Dim Paths   As Range
Dim Path    As Range
Dim MyArr   As Variant
Dim pNum    As Long
Dim pBuf    As String
Dim Delim   As String

Set Paths = Range("A:A").SpecialCells(xlConstants)
Delim = Application.PathSeparator
On Error Resume Next
   
    For Each Path In Paths
        MyArr = Split(Path, Delim)
        pBuf = MyArr(LBound(MyArr)) & Delim
        For pNum = LBound(MyArr) + 1 To UBound(MyArr)
            pBuf = pBuf & MyArr(pNum) & Delim
            MkDir pBuf
        Next pNum
        pBuf = ""
    Next Path

Set Paths = Nothing

End Sub


USER DEFINED FUNCTION version

This version is intended to be used by other macros.  Call the function and feed in a full path string, the function will make sure all the folders exist from the top of the tree all the way down.

EXAMPLE:
In cell A1              C:\2013\Test\DeepTest\

And this line of code:
            
MakeFolders (Range("A1").Text)


UDF

Function MakeFolders(MyStr As String)
'Author:    Jerry Beaucaire
'Date:      7/14/2010
'Summary:   Create directories and subdirectories based
'           on the text strings fed to the function
'           This version is to be called by other macros
'           10/19/2010 - International compliant
Dim MyArr   As Variant
Dim pNum    As Long
Dim pBuf    As String
Dim Delim   As String

On Error Resume Next
Delim = Application.PathSeparator

    MyArr = Split(MyStr, Delim)
    pBuf = MyArr(LBound(MyArr)) & Delim
    For pNum = LBound(MyArr) + 1 To UBound(MyArr)
        pBuf = pBuf & MyArr(pNum) & Delim
        MkDir pBuf
    Next pNum

End Function



Nothing says "thanks" like a steak dinner!
PayPal - The safer, easier way to pay online!

Comments