title: How to create folders using Excel VBA?
body: <p>This is the entire code that goes from importing an Excel document to creating folders using an Excel spreadsheet. </p>
  
  <pre><code>Sub Update_JL()
  
  Dim wsJL As Worksheet 'Open Orders
  Dim wsJOD As Worksheet 'Jobs Data
  Dim wsJAR As Worksheet 'JL Archive
  Dim wbBK1 As Workbook
  Dim wbBK2 As Workbook
  Dim wsBOR As Worksheet
  Dim lastrow As Long, fstcell As Long, strCompany As String, strPart As String, strPath As String, strFile As String
  Dim cell As Range, newFolder As String, PhotoDir As String
  
  Set wsJL = Sheets("Open Orders")
  Set wsJOD = Sheets("Jobs Data")
  Set wsJAR = Sheets("JL Archive")
  Set wbBK1 = ThisWorkbook
  Set wbBK2 = ActiveWorkbook
  
  Application.ScreenUpdating = False    ' Prevents screen refreshing.
  Application.Calculation = xlCalculationManual
  
  With wsJOD
      .Columns("A:Q").Clear
      wsJL.Range("B2:I2").Copy wsJOD.Range("A1")
      .Range("I1").Formula = "=COUNTIFS('Open Orders'!$B:$B,$A1,'Open Orders'!$D:$D,$C1)"
      .Range("J1").Formula = "=IF(I1,""Same"",""Different"")"
  End With
  
  strFile = Application.GetOpenFilename()
  Set wbBK2 = Application.Workbooks.Open(strFile)
  Set wsBOR = Sheets(Replace(wbBK2.Name, ".csv", ""))
  
  lastrow = wsBOR.Range("C" &amp; Rows.Count).End(xlUp).Row
  wsBOR.Range("B6:E" &amp; lastrow).Copy wsJOD.Range("A2")
  wsBOR.Range("G6:H" &amp; lastrow).Copy wsJOD.Range("E2")
  wsBOR.Range("L6:L" &amp; lastrow).Copy wsJOD.Range("G2")
  wsBOR.Range("N6:N" &amp; lastrow).Copy wsJOD.Range("H2")
  wbBK2.Close
  
  lastrow = wsJOD.Range("A" &amp; Rows.Count).End(xlUp).Row
  wsJOD.Range("I1:J1").Copy wsJOD.Range("I2:J" &amp; lastrow)
  wsJOD.Range("I2:J" &amp; lastrow).Calculate
  
  lastrow = wsJL.Range("B" &amp; Rows.Count).End(xlUp).Row
  wsJL.Range("P2:R2").Copy wsJL.Range("P3:R" &amp; lastrow)
  wsJL.Range("P3:R" &amp; lastrow).Calculate
  
  With Intersect(wsJL.UsedRange, wsJL.Columns("Q"))
      .AutoFilter 1, "&lt;&gt;Same"
      With Intersect(.Offset(2).EntireRow, .Parent.Range("B:U"))
          .Copy wsJAR.Cells(Rows.Count, "B").End(xlUp).Offset(1)
          .EntireRow.Delete
      End With
      .AutoFilter
  End With
  
  lastrow = wsJOD.Range("A" &amp; Rows.Count).End(xlUp).Row
  
  With Intersect(wsJOD.UsedRange, wsJOD.Range("J2:J" &amp; lastrow))
      .AutoFilter 1, "&lt;&gt;Different"
      .SpecialCells(xlCellTypeVisible).EntireRow.Delete
  End With
  
  wsJOD.Range("A2:H" &amp; lastrow).Copy wsJL.Cells(Rows.Count, "B").End(xlUp).Offset(1)
  wsJOD.Columns("A:Q").Clear
  
  lastrow = wsJL.Range("B" &amp; Rows.Count).End(xlUp).Row
  wsJL.Range("J3:K3").Copy wsJL.Range("J4:K" &amp; lastrow)
  wsJL.Range("B3:N3").Copy
  wsJL.Range("B4:N" &amp; lastrow).Borders.Weight = xlThin
  wsJL.Range("B4:N" &amp; lastrow).Font.Size = 11
  wsJL.Range("B4:N" &amp; lastrow).Font.Name = "Calibri"
  wsJL.Range("J3:K" &amp; lastrow).Calculate
  
  'Sort PO Tracking 
  With wsJL
      .Sort.SortFields.Clear
  
  'Sort Reds
      .Sort.SortFields.Add(.Range("K3:K" &amp; lastrow), _
      xlSortOnIcon, xlAscending, , xlSortNormal).SetIcon Icon:=ActiveWorkbook. _
      IconSets(4).Item(1)
  
      .Sort.SortFields.Add Key:=Range( _
      "K3:K" &amp; lastrow), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:= _
      xlSortNormal
  
  'Sort Yellows
      .Sort.SortFields.Add(.Range("J3:J" &amp; lastrow), _
      xlSortOnIcon, xlAscending, , xlSortNormal).SetIcon Icon:=ActiveWorkbook. _
      IconSets(4).Item(2)
  
  'Sort Greens
      .Sort.SortFields.Add(.Range("J3:J" &amp; lastrow), _
      xlSortOnIcon, xlAscending, , xlSortNormal).SetIcon Icon:=ActiveWorkbook. _
      IconSets(4).Item(3)
  
      .Sort.SortFields.Add Key:=Range( _
      "J3:J" &amp; lastrow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
      xlSortNormal
  
      With .Sort
          .SetRange wsJL.Range("B2:U" &amp; lastrow)
          .Header = xlYes
          .MatchCase = False
          .Orientation = xlTopToBottom
          .SortMethod = xlPinYin
          .Apply
      End With
      lastrow = wsJL.Range("B" &amp; Rows.Count).End(xlUp).Row
      wsJL.Range("B3:N" &amp; lastrow).Select
      wsJL.Range("B3:N" &amp; lastrow).VerticalAlignment = xlCenter
      wsJL.Range("A1").Select
  End With
  
  With wsJL
  
      strCompany = CleanName(Range("C3")) ' assumes company name starts in C
      strPart = CleanName(Range("D3")) ' assumes part in D
      strPath = wbBK1.path &amp; Application.PathSeparator &amp; "Photos" &amp; Application.PathSeparator
  
      If Not FolderExists(strPath &amp; strCompany) Then
          'company doesn't exist, so create full path
          FolderCreate strPath &amp; strCompany &amp; Application.PathSeparator &amp; strPart
      Else
          'company does exist, but does part folder
          If Not FolderExists(strPath &amp; strCompany &amp; Application.PathSeparator &amp; strPart) Then
              FolderCreate strPath &amp; strCompany &amp; Application.PathSeparator &amp; strPart
          End If
      End If
  
      Range("J:M").Calculate
  
  End With
  
  Application.ScreenUpdating = True
  Application.Calculation = xlCalculationAutomatic
  
  MsgBox "Open Orders Updated!"
  
  End Sub
  </code></pre>
  
  <p>The functions: </p>
  
  <pre><code>Function FolderCreate(ByVal path As String) As Boolean
  
  FolderCreate = True
  Dim fso As New FileSystemObject
  
  If 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: " &amp; path &amp; ". 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(strIn 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
  
  Dim objRegex As Object
  Set objRegex = CreateObject("vbscript.regexp")
  With objRegex
  .Global = True
  .Pattern = "[,\/\*\.\\""""]+"
  CleanName = .Replace(strIn, vbNullString)
  End With
  End Function
  </code></pre>
  
  <p><a href="https://i.stack.imgur.com/wzOuy.jpg" rel="nofollow noreferrer"><img src="https://i.stack.imgur.com/wzOuy.jpg" alt="Error"></a><br>
  <sub>(source: <a href="http://www.kaboomlabs.com/excel/img/error6.jpg" rel="nofollow noreferrer">kaboomlabs.com</a>)</sub>  </p>
  
  <p>As you see above C3 should be cleaned up. I don't have the folder protected or locked. I created the folder yesterday in hopes to get it working.</p>
  
  <p>Code and information here: <a href="http://www.kaboomlabs.com/excel/examples/CreateFolder.zip" rel="nofollow noreferrer">CreateFolder Sheet and scripts</a></p>