How to create folders using Excel VBA?

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

There's nothing wrong with your clean string, it is executing successfully. I think the problem is the way you are creating files, I can't see the CreateFolder code, but at a guess it uses MkDir. MkDir only allows you to create a single folder at once - You're trying to create 2 — SWa, Sep 25 '12 at 12:35

JustinJDavies · Answer 1 · 2012-09-25T13:08:35.193

0

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

edited Sep 25 '12 at 13:08

answered Sep 25 '12 at 12:42

JustinJDavies

2,663
4
30
52

Change which part? I hate to ask... but I don't like overwriting code without knowing why... – Matt Ridge Sep 25 '12 at 12:58
Replace the code as indicated in my edit above. You cannot create the 'part' folder until the parent 'company' folder has been created first – JustinJDavies Sep 25 '12 at 13:07
It just says the folder can't be created, doesn't say why, just says it can't. the naming convention is correct btw. – Matt Ridge Sep 25 '12 at 14:55
Can you create the folder manually? It is very difficult to diagnose what is causing your issue – JustinJDavies Sep 25 '12 at 17:04
yes, no problem, and I know it's difficult to diagnose, otherwise I wouldn't of asked :) – Matt Ridge Sep 25 '12 at 17:44
OP updated and full script is here: http://www.kaboomlabs.com/excel/examples/CreateFolder.zip – Matt Ridge Sep 27 '12 at 17:58

SWa · Answer 2 · 2012-09-25T15:30:15.700

0

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.

edited Sep 25 '12 at 15:30

answered Sep 25 '12 at 12:54

SWa

4,343
23
40

Except I need this to work on a Mac or PC. So will this code work on both? – Matt Ridge Sep 25 '12 at 12:59
I think it would, Dir does, but I'm not sure about MkDir - though I'm tempted to say it will. The FileSystemObject does not exist in the Mac world though, so if you're using it anywhere else, you'll need a workaround. You might want to replace the "\" with application.fileseperator though - I think would give you the right syntax – SWa Sep 25 '12 at 13:03
You would use this function in place of FolderCreate – SWa Sep 25 '12 at 14:57
Dim x is not defined, it won't work, may want to correct that ;) – Matt Ridge Sep 25 '12 at 15:11
Ok, tried it, and I was getting a Run-time error `52': Bad file name or number here, 'If Len(Dir(pPath, vbDirectory)) = 0 Then` – Matt Ridge Sep 25 '12 at 16:04
Is that on a Mac or a PC? What's the value of ppath? – SWa Sep 25 '12 at 16:27
PC, and the value of ppath is: `pPath = "C:\Matts'\Stuff\Dropbox\OOR\Photos\Vactor"` Seems to me that it's breaking up a folder when it shouldn't be: `C:\Matts' Stuff\Dropbox\OOR\Photos\` – Matt Ridge Sep 25 '12 at 16:34
Are you actually using the code I posted or have you altered it? Your error suggests you are running the split() function without the second parameter i.e "\". Without a second parameter, split will split a string based on a space – SWa Sep 25 '12 at 16:55
I replaced the `"\"` with the `Application.PathSeparator` – Matt Ridge Sep 25 '12 at 17:36
let us [continue this discussion in chat](http://chat.stackoverflow.com/rooms/17142/discussion-between-matt-ridge-and-kyle) – Matt Ridge Sep 25 '12 at 18:01
My chat isn't working for some reason, in any case, my last response was: Ok, did as you asked, and it didn't create the folders, even though I can manually do so – Matt Ridge Sep 25 '12 at 18:20
I can't replicate your problem in any way. I suggest uploading your workbook (or a mock up that exhibits the same problem) to a sharing site so we can have a look – SWa Sep 26 '12 at 07:26
OP updated, and script is here: http://www.kaboomlabs.com/excel/examples/CreateFolder.zip – Matt Ridge Sep 27 '12 at 17:58
My code works fine with: createpath(thisworkbook.path & Application.PathSeparator & "Photos" & Application.PathSeparator & CleanName(Range("C3")) & application.PathSeparator & CleanName(Range("D3"))) – SWa Sep 28 '12 at 07:20
Could this be anything to do with you trying to create a folder in a dropbox folder? – SWa Sep 28 '12 at 07:21
No, because the "Dropbox" folder you are talking about is a folder that resides on the hard drive, it is not a virtural drive or folder. As for your code working, I'm trying to get it to work in my situation. If you download the file I showed you, you'll see what I am dealing with. – Matt Ridge Sep 28 '12 at 11:11

Matt Ridge · Accepted Answer · 2012-09-28T14:04:57.180

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.

How to create folders using Excel VBA?

3 Answers3

Linked