I am using this code to create folders based on names mentioned in Column A, however at times this does not create folders and at times it does not create all the folders. I could not figure out the issue or if anything is missing in it.

I will really appreciate if any amendment could be made where if a particular folder is already available (based on cell value) it does not show error.

Sub MakeFolders()
  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

CodePudding user response：

Please, try the next adapted code. It uses an array, all iteration being done in memory (much faster than iterating between cells) and checks if a cell is empty or contains illegal characters, not accepted in a path:

Sub MakeFolders()
  Dim sh As Worksheet, lastR As Long, arr, i As Long, rootPath As String
  
  Set sh = ActiveSheet
  lastR = sh.Range("A" & sh.rows.count).End(xlUp).row
  
   arr = sh.Range("A2:A" & lastR).Value2

  rootPath = ThisWorkbook.Path & "\"
  For i = 1 To UBound(arr)
        If arr(i, 1) <> "" And noIllegalChars(CStr(arr(i, 1))) Then
                If Dir(rootPath & arr(i, 1), vbDirectory) = "" Then
                    MkDir rootPath & arr(i, 1)
                End If
        Else
                MsgBox "Illegals characters or empty cell (" & sh.Range("A" & i   1).address & ")..."
        End If
  Next i
End Sub

Function noIllegalChars(x As String) As Boolean
   Const illCh As String = "*[\/\\"":\*?]*"
   If Not x Like illCh Then noIllegalChars = True
End Function

It iterates between (existing) cells in column A:A and check if they are empty, do not contain illegal characters or the folder has already been created.

CodePudding user response：

Create Folders From Range Selection

• This solution creates folders simply if it is possible i.e. based on On Error Resume Next making it kind of a hack.
• To 'make amends' on the hack part, it returns a table, containing some stats about the folders that could not be created, in the Immediate window (Ctrl G).
• If you're not interested at all in why a folder was not created, remove the Debug Print routine i.e. the lines ending in ' DP.

Option Explicit

Sub CreateFoldersFromSelection()
   
    If Selection Is Nothing Then Exit Sub
    If Not TypeOf Selection Is Range Then Exit Sub
    
    ' Set the workbook...
    Dim wb As Workbook: Set wb = Selection.Worksheet.Parent
    ' ... to build the path.
    Dim fPath As String: fPath = wb.Path & Application.PathSeparator
    
    Dim arg As Range, Data() As Variant
    Dim r As Long, c As Long, rCount As Long, cCount As Long
    Dim ErrNum As Long, ErrDescription As String ' DP
    
    Debug.Print "Folders in '" & fPath & "' not created:" ' DP
    Debug.Print "Name", "Cell Address", "Error Number", "Error Description" ' DP
    
    ' Loop over each area of the selection...
    For Each arg In Selection.Areas
        ' ... to return the area's values in an array, ...
        rCount = arg.Rows.Count
        cCount = arg.Columns.Count
        If rCount * cCount = 1 Then
            ReDim Data(1 To 1, 1 To 1): Data(1, 1) = arg.Value
        Else
            Data = arg.Value
        End If
        ' ... then loop over the values in the array...
        For r = 1 To rCount
            For c = 1 To cCount
                ' ... to attempt to create the current folder.
                On Error Resume Next
                    MkDir fPath & Data(r, c)
                    ErrNum = Err.Number ' DP
                    ErrDescription = Split(Err.Description, vbLf)(0) & "..." ' DP
                On Error GoTo 0
                If ErrNum <> 0 Then ' DP
                    ' Print a line of stats about the folder not created.
                    Debug.Print Data(r, c), arg.Cells(r, c).Address(0, 0), _
                        ErrNum, ErrDescription ' DP
                End If ' DP
            Next c
        Next r
    Next arg

    MsgBox "Folders created.", vbInformation
    
End Sub