VBA - creating folders to be automated

[superfb]

Hi All,

I have the following code..

Dim lngCount As Long, Msg As String
lngCount = 2
If Len(Dir(Cells(1, 20), vbDirectory)) = 0 Then
   MkDir Cells(1, 20)
Else
    Do Until Len(Dir(Cells(1, 20) & " - " & lngCount, vbDirectory)) = 0
        lngCount = lngCount + 1
    Loop
   MkDir Cells(1, 20) & " - " & lngCount
   Msg = " - " & lngCount
End If

' message box
MsgBox "Folder Created for:" & vbCr & vbCr & Format(Cells(2, 12), "YYYYMMDD") & Msg, vbOKOnly, "View History Report"

Is there a way to loop it so it creates the folder in column c and goes up to create next one, so after I select ok on msgbx ......

 

[superfb]

Also it says variable C isnt defined

 

[superfb]

MkDir dirName


Also this part of the code causes an error ( i was thinking col n will have the path contained and the folder to create....)

 

[superfb]

it creates the folders but crashes on the MKDir code, which means it doesnt create the folders in a batch of 5......

 

[Joe4]

OK, there were a few typos.

This version has the corrections and you new requirements. I was able to test it out, and it appears to be working properly.

Sub MakeFolders()

    Dim lastRow As Long
    Dim r As Long
    Dim dirName As String
    Dim sfx As Long
    Dim ct As Long
    Dim fldrs As String
    Dim cont
    
'   Find last row with data in column D
    lastRow = Cells(Rows.Count, "D").End(xlUp).Row
    
'   Loop through all rows, starting on row 1
    For r = 1 To lastRow
        dirName = Cells(r, "D")
'       Loop until file name is new
        sfx = 0
        Do Until Len(Dir(dirName, vbDirectory)) = 0
            Select Case sfx
                Case 0
                    sfx = 2
                    dirName = dirName & " - " & sfx
                Case Else
                    sfx = sfx + 1
                    dirName = Left(dirName, InStr(dirName, "-")) & " " & sfx
            End Select
        Loop
        MkDir dirName
'       Add folder name to list and increment count
        ct = ct + 1
        fldrs = fldrs & "Folder created with name: " & dirName & vbCrLf
        If ct = 5 Then
'           Return message box after 5 and ask if they want to continue
            cont = MsgBox(fldrs, vbYesNo, "Do You Want to Continue?")
            If cont = vbNo Then
'               If no, exit sub
                Exit Sub
            Else
'               Else reset counts and continue
                ct = 0
                fldrs = ""
            End If
        End If
    Next r
    
'   Last message box
    If Len(fldrs) > 0 Then MsgBox fldrs, vbOKOnly, "Last Folders Created"

End Sub

 

[superfb]

OK, there were a few typos.

This version has the corrections and you new requirements. I was able to test it out, and it appears to be working properly.

Sub MakeFolders()

    Dim lastRow As Long
    Dim r As Long
    Dim dirName As String
    Dim sfx As Long
    Dim ct As Long
    Dim fldrs As String
    Dim cont
    
'   Find last row with data in column D
    lastRow = Cells(Rows.Count, "D").End(xlUp).Row
    
'   Loop through all rows, starting on row 1
    For r = 1 To lastRow
        dirName = Cells(r, "D")
'       Loop until file name is new
        sfx = 0
        Do Until Len(Dir(dirName, vbDirectory)) = 0
            Select Case sfx
                Case 0
                    sfx = 2
                    dirName = dirName & " - " & sfx
                Case Else
                    sfx = sfx + 1
                    dirName = Left(dirName, InStr(dirName, "-")) & " " & sfx
            End Select
        Loop
        MkDir dirName
'       Add folder name to list and increment count
        ct = ct + 1
        fldrs = fldrs & "Folder created with name: " & dirName & vbCrLf
        If ct = 5 Then
'           Return message box after 5 and ask if they want to continue
            cont = MsgBox(fldrs, vbYesNo, "Do You Want to Continue?")
            If cont = vbNo Then
'               If no, exit sub
                Exit Sub
            Else
'               Else reset counts and continue
                ct = 0
                fldrs = ""
            End If
        End If
    Next r
    
'   Last message box
    If Len(fldrs) > 0 Then MsgBox fldrs, vbOKOnly, "Last Folders Created"

End Sub

Hi thank you for this, it seems to be working better.


Do you think i should have the file location in a seperate cell rather than combining it with the folder name to be created? Reason i ask is because the msg box shows the file path and folder created, where as it would be easier if the folder created was shown....

additionally if i select no, is there a way where the cursor could stay at the cell where i need to create the next batch (consequently delting the folder names already created)

 

[Joe4]

However, it does not create folders in batches of 5 followed by a message box asking you to continue whilst showing the folders created.

I tested it multiple times, and it does.
I tested on a list of 12 records, and it stopped after 5 and 10, with complete listings of each one, and then did a residual MsgBox to list the last 2 folders.

Did you copy and paste my code, exactly as-is, or are you trying to manually copy it by typing it in yourself?
I ask because this was one of the sections that had typos that I needed to fix, and I suspect maybe you missed that correction.

 

[superfb]

Hi apologies it does work! And i think I edited my comments whilst you replied......please read earlier comment

 

[Joe4]

Do you think i should have the file location in a seperate cell rather than combining it with the folder name to be created? Reason i ask is because the msg box shows the file path and folder created, where as it would be easier if the folder created was shown....

Sure, go for it. Whatever works best for you. This should be pretty easy for you to do.

additionally if i select no, is there a way where the cursor could stay at the cell where i need to create the next batch (consequently delting the folder names already created)

To select the cell where you left off, just add the line in red to this current IF...THEN block in your code.

'           Return message box after 5 and ask if they want to continue
            cont = MsgBox(fldrs, vbYesNo, "Do You Want to Continue?")
            If cont = vbNo Then
'               If no, select next cell and exit sub
[COLOR=#ff0000]                Cells(r + 1, "D").Select[/COLOR]
                Exit Sub
            Else
'               Else reset counts and continue
                ct = 0
                fldrs = ""
            End If

You could delete all the entries above it if you like by adding the following line above the one in red:

Range("D1:D" & r).ClearContents