Create a Directory with VBA

[Amnesiac]

I wrote a macro which currently creates new folders based on names in column A. Currently, the macro creates the folders where the Excel sheet is saved. I would like to modify this to create the folders in a separate directory from the spreadsheet, as well as being able to add sub-folders to each folder it creates. Suggestions for the best method to go about this?

Sub MakeFolders()
'create the folders whereever the workbook is saved
Dim Rng As Range

Dim maxRows, maxCols, r, c As Integer

Set Rng = Selection

maxRows = Rng.Rows.Count

maxCols = Rng.Columns.Count

For c = 1 To maxCols

r = 1

Do While r <= maxRows

If Len(Dir(ActiveWorkbook.Path & "\" & Rng(r, c), vbDirectory)) = 0 Then

MkDir (ActiveWorkbook.Path & "\" & Rng(r, c))

On Error Resume Next

End If

r = r + 1

Loop

Next c
End Sub

 

[Ralajer]

This may be a little over kill depending on you application but this what I had in my personal library of functions.

Slightly modified what you had to incorporate helper functions and changing the For loop and Do while into a For Each Loop

Sub MakeFolders()
   
    Dim Rng As Range, cell As Range
    Dim basePath As String, dynPath As String
    
    '// =======================================================================
    '// Use if you want to use workbook directory
    '//
    'Dim wbPath As String
    'wbPath = ActiveWorkbook.Path & "\"
    
    basePath = "C:\Test\Dir1\Dir 2\Dir3\"
    '// =======================================================================
    '// Use helper functions to validate folder exist and create dir structure
    '//     if it does not exist
    
    validateCreateDir basePath

    Set Rng = Selection
    
    On Error Resume Next
    
    For Each cell In Rng
        dynPath = baseBase & cell.Value
        If Len(Dir(dynPath, vbDirectory)) = 0 Then
                MkDir dynPath
        End If
    Next cell

End Sub

This checks to see if the directory structure is in place creating if it is not.

Private Function validateCreateDir(dirPath As String)
'// ===========================================================================
'// Takes string array of directory paths

    Dim arrLen As Integer
    Dim arrDir() As String
    Dim i As Integer, levelExist As Integer
    
    arrDir() = dirHierarchy(dirPath)
    
    arrLen = UBound(arrDir)
    For i = arrLen To 1 Step -1
        If Len(Dir(arrDir(i), vbDirectory)) <> 0 Then
            levelExist = i
            '// Exit function if whole path exist
            If levelExist = arrLen Then Exit Function
            Exit For
        End If
    Next i
    
    For i = levelExist To arrLen
        If Len(Dir(arrDir(i), vbDirectory)) = 0 Then
            MkDir (arrDir(i))
        End If
    Next i
End Function

Used by above function to parse path information and structure

Private Function dirHierarchy(ByVal dirPath As String) As String()
'// ===========================================================================
'// Returns a string array containing path of the folder hieracrchy
'// Example: Pass -- C:\Program Files\Microsoft Office\Office14\
'// Returns:
'//         arr(1) = C:\
'//         arr(2) = C:\Program Files\
'//         arr(3) = C:\Program Files\Microsoft Office\
'//         arr(4) = C:\Program Files\Microsoft Office\Office14\
    
    
    Dim dT As String
    Dim dirH() As String
    Dim i As Integer, pos As Integer, numDir As Integer
    
    dT = "\"        '\\ Directory Seporator
    
    '// =======================================================================
    '// Add slash(\) to end of path to simplify conditions below
    '//
    If InStrRev(dirPath, dT) <> Len(dirPath) Then
        dirPath = dirPath & dT
    End If
    '// =======================================================================
    '// Count the number of sub directories
    '//
    Do While InStr(pos + 1, dirPath, dT) > 0
        numDir = 1 + numDir
        pos = InStr(pos + 1, dirPath, dT)
    Loop
    
    ReDim dirH(1 To numDir)
    
    pos = 1
    '// =======================================================================
    '// Parse the sub directorys into Sring array
    '//
    For i = 1 To numDir
        dirH(i) = Mid(dirPath, 1, InStr(pos, dirPath, dT))
        pos = InStr(pos, dirPath, dT) + 1
    Next i
    
    dirHierarchy = dirH()
   
End Function

As for adding sub folder that all depends on how you want to do that. If you want the same folders in every directory currently in the selection range you could place them in a seperate range and For Each loop through them. By adding this and removing the for each loop in the sub.

    Dim rngSubDir As Range, cell2 As Range
    Dim dynPath2 As String
    Set rngSubDir = Worksheets("Sheet1").Range("B2:C4") '//Range with subfolders
    
    For Each cell In Rng
        dynPath = baseBase & cell.Value
        If Len(Dir(dynPath, vbDirectory)) = 0 Then
                MkDir dynPath
        End If
        For Each cell2 In rngSubDir
            dynPath2 = dynPath & cell2.Value
        If Len(Dir(dynPath, vbDirectory)) = 0 Then
                MkDir dynPath
        End If
        Next cell2
    Next cell

Let me know if you have question.