How to create folders using Excel VBA? - excel

Question

This is the entire code that goes from importing an Excel document to creating folders using an Excel spreadsheet.
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" & Rows.Count).End(xlUp).Row
wsBOR.Range("B6:E" & lastrow).Copy wsJOD.Range("A2")
wsBOR.Range("G6:H" & lastrow).Copy wsJOD.Range("E2")
wsBOR.Range("L6:L" & lastrow).Copy wsJOD.Range("G2")
wsBOR.Range("N6:N" & lastrow).Copy wsJOD.Range("H2")
wbBK2.Close
lastrow = wsJOD.Range("A" & Rows.Count).End(xlUp).Row
wsJOD.Range("I1:J1").Copy wsJOD.Range("I2:J" & lastrow)
wsJOD.Range("I2:J" & lastrow).Calculate
lastrow = wsJL.Range("B" & Rows.Count).End(xlUp).Row
wsJL.Range("P2:R2").Copy wsJL.Range("P3:R" & lastrow)
wsJL.Range("P3:R" & lastrow).Calculate
With Intersect(wsJL.UsedRange, wsJL.Columns("Q"))
.AutoFilter 1, "<>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" & Rows.Count).End(xlUp).Row
With Intersect(wsJOD.UsedRange, wsJOD.Range("J2:J" & lastrow))
.AutoFilter 1, "<>Different"
.SpecialCells(xlCellTypeVisible).EntireRow.Delete
End With
wsJOD.Range("A2:H" & lastrow).Copy wsJL.Cells(Rows.Count, "B").End(xlUp).Offset(1)
wsJOD.Columns("A:Q").Clear
lastrow = wsJL.Range("B" & Rows.Count).End(xlUp).Row
wsJL.Range("J3:K3").Copy wsJL.Range("J4:K" & lastrow)
wsJL.Range("B3:N3").Copy
wsJL.Range("B4:N" & lastrow).Borders.Weight = xlThin
wsJL.Range("B4:N" & lastrow).Font.Size = 11
wsJL.Range("B4:N" & lastrow).Font.Name = "Calibri"
wsJL.Range("J3:K" & lastrow).Calculate
'Sort PO Tracking
With wsJL
.Sort.SortFields.Clear
'Sort Reds
.Sort.SortFields.Add(.Range("K3:K" & lastrow), _
xlSortOnIcon, xlAscending, , xlSortNormal).SetIcon Icon:=ActiveWorkbook. _
IconSets(4).Item(1)
.Sort.SortFields.Add Key:=Range( _
"K3:K" & lastrow), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:= _
xlSortNormal
'Sort Yellows
.Sort.SortFields.Add(.Range("J3:J" & lastrow), _
xlSortOnIcon, xlAscending, , xlSortNormal).SetIcon Icon:=ActiveWorkbook. _
IconSets(4).Item(2)
'Sort Greens
.Sort.SortFields.Add(.Range("J3:J" & lastrow), _
xlSortOnIcon, xlAscending, , xlSortNormal).SetIcon Icon:=ActiveWorkbook. _
IconSets(4).Item(3)
.Sort.SortFields.Add Key:=Range( _
"J3:J" & lastrow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
With .Sort
.SetRange wsJL.Range("B2:U" & lastrow)
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
lastrow = wsJL.Range("B" & Rows.Count).End(xlUp).Row
wsJL.Range("B3:N" & lastrow).Select
wsJL.Range("B3:N" & 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 & Application.PathSeparator & "Photos" & Application.PathSeparator
If Not FolderExists(strPath & strCompany) Then
'company doesn't exist, so create full path
FolderCreate strPath & strCompany & Application.PathSeparator & strPart
Else
'company does exist, but does part folder
If Not FolderExists(strPath & strCompany & Application.PathSeparator & strPart) Then
FolderCreate strPath & strCompany & Application.PathSeparator & strPart
End If
End If
Range("J:M").Calculate
End With
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
MsgBox "Open Orders Updated!"
End Sub
The functions:
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: " & 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(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
(source: kaboomlabs.com)
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.
Code and information here: CreateFolder Sheet and scripts

Answer 1

Try changing your code to
If Not FolderExists(strPath & strCompany) Then
'Company doesn't exist, so first create company folder and then part folder
FolderCreate strPath & strCompany
FolderCreate strPath & strCompany & Application.PathSeparator & strPart
Else
'company does exist, but does part folder
If Not FolderExists(strPath & strCompany & Application.PathSeparator & strPart) Then
FolderCreate strPath & strCompany & Application.PathSeparator & strPart
End If
End If
EDIT:
replace this bit:
If Not FolderExists(strPath & strCompany) Then
'company doesn't exist, so create full path
FolderCreate strPath & strCompany & Application.PathSeparator & strPart
Else
'company does exist, but does part folder
If Not FolderExists(strPath & strCompany & Application.PathSeparator & strPart) Then
FolderCreate strPath & strCompany & Application.PathSeparator & strPart
End If
End If

Answer 2

No Problem
The issue is that the way you are creating folders will only allow you to create one at a time. So you need to build the path up, maybe something like:
Function CreatePath(path As String) As Boolean
Dim pPath As String
Dim x as long
Dim arr
arr = Split(path, "\")
For x = LBound(arr) To UBound(arr)
If x = 0 Then
pPath = arr(x)
Else
pPath = pPath & "\" & arr(x)
End If
If Len(Dir(pPath, vbDirectory)) = 0 Then MkDir pPath
Next x
If Len(Dir(pPath, vbDirectory)) > 0 Then CreatePath = True
End Function
Which will create a path of any depth.

Answer 3

Ok, it with an old script I have, added more stuff to the workbook cell wise, but it works the way I need it too.
Here is the code:
Dim baseFolder As String, newFolder As String
lastrow = wsJL.Cells(Rows.Count, "B").End(xlUp).Row
wsJL.Range("S2:U2").Copy wsJL.Range("S3:U" & lastrow)
Range("J3:M" & lastrow).Calculate
Range("S3:U" & lastrow).Calculate
baseFolder = wbBK1.path & Application.PathSeparator & "Photos" & Application.PathSeparator
'folders will be created within this folder - Change to sheet of your like.
If Right(baseFolder, 1) <> Application.PathSeparator Then _
baseFolder = baseFolder & Application.PathSeparator
For Each cell In Range("S3:S" & lastrow) 'CHANGE TO SUIT
'Company folder - column S
newFolder = baseFolder & cell.Value
If Len(Dir(newFolder, vbDirectory)) = 0 Then MkDir newFolder
'Part number subfolder - column T
newFolder = newFolder & Application.PathSeparator & cell.Offset(0, 1).Value
If Len(Dir(newFolder, vbDirectory)) = 0 Then MkDir newFolder
Next
End With
I have in S and T is this:
S
=TRIM(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE($C2,",","")," "," "),".",""),"/","-"),"""",""),"*",""))
T
=TRIM(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE($D2,",","")," "," "),".",""),"/","-"),"""",""),"*",""))
This trims the end of all the cells of any blank spaces that we don't see, and cleans up the cells so it's accurate and possible to have a folder created in it.