VBA to create folder and subfolder

[OfficeUser]

Hi, I am using this macro to create a folder, and then two predetermined folders within:

Sub MakeFolders()
    Dim xdir As String
    Dim fso
    Dim lstrow As Long
    Dim i As Long
    Set fso = CreateObject("Scripting.FileSystemObject")
    lstrow = ActiveSheet.Cells(ActiveSheet.Rows.Count, "B").End(xlUp).Row
    Application.ScreenUpdating = False
    For i = 2 To 150 '<-- reads list from B2
        'change the path on the next line where you want to create the folders
        xdir = "C:\Prontoforms\" & Range("B" & i).Value
        If Not fso.FolderExists(xdir) Then
            fso.CreateFolder (xdir)
            MkDir (xdir) & "\Weekdays"
            MkDir (xdir) & "\Weekends"
        End If
    Next
    Application.ScreenUpdating = True
End Sub

The issue is that it will always create folder using cell value in Column B but it will always error out eventually on this line:

MkDir (xdir) & "\Weekdays"

Not sure where to go from here, works fine, then gets the hiccups. Any resources I should look at?

 

[Trebor76]

Hi OfficeUser,

The code works for me What error message are you getting? If it's Run-time error '13:' Type mismatch make ensure there's no errors like #DIV0! in the range B2:B150. If not hover over xdir and try to create that directory manually (if you're using a work PC or laptop maybe you need admin rights to create folders on that machine's C drive).

Hope that helps.

Robert

 

[OfficeUser]

Hi OfficeUser,

The code works for me What error message are you getting? If it's Run-time error '13:' Type mismatch make ensure there's no errors like #DIV0! in the range B2:B150. If not hover over xdir and try to create that directory manually (if you're using a work PC or laptop maybe you need admin rights to create folders on that machine's C drive).

Hope that helps.

Robert

I am getting Run-Time Error '76': Path not found. It makes them until about the 11th one to do.

 

[Trebor76]

Maybe add...

DoEvents

...immediately below this line:

MkDir (xdir) & "\Weekends"

Not too sure what else to suggest after that I'm afraid

 

[OfficeUser]

Maybe add...

DoEvents

...immediately below this line:

MkDir (xdir) & "\Weekends"

Not too sure what else to suggest after that I'm afraid

Maybe add...

DoEvents

...immediately below this line:

MkDir (xdir) & "\Weekends"

Not too sure what else to suggest after that I'm afraid

I tried what you suggested, didnt work. I do appreciate you taking time to help though.

 

[Trebor76]

Did you try manually making the folder for the line that's failing?

 

[OfficeUser]

Did you try manually making the folder for the line that's failing?

Did you try manually making the folder for the line that's failing?

No, though I have tried to simplify the macro and made a test using nothing more than numbers in cells B2:B15 (one, two, three, etc.) It still hiccups. I been trying to find another way to write it, striking out.

 

[OfficeUser]

No, though I have tried to simplify the macro and made a test using nothing more than numbers in cells B2:B15 (one, two, three, etc.) It still hiccups. I been trying to find another way to write it, striking out.

So if I remove the both MkDir lines it will make all the folders, but I do need the two subfolders inside each parent that is created

 

[Trebor76]

Try this where each part of the folder path is checked and if any part of it does not exist it is created:

Option Explicit
Sub MakeFolders()

    Dim xdir As String, strTemp As String
    Dim fso As Object
    Dim lstrow As Long
    Dim i As Long, j As Long
    Dim varPath As Variant
   
    Application.ScreenUpdating = False
   
    Set fso = CreateObject("Scripting.FileSystemObject")
    lstrow = ActiveSheet.Cells(ActiveSheet.Rows.Count, "B").End(xlUp).Row
   
    For i = 2 To lstrow '<-- reads list from B2
        If Len(Range("B" & i).Value) > 0 Then
            'change the path on the next line where you want to create the folders
            For j = 1 To 2 '1 for Weekdays folder, 2 for Weekends folder
                xdir = "C:\Prontoforms\" & Range("B" & i).Value & "\" & Choose(j, "Weekdays", "Weekends")
                For Each varPath In Split(xdir, "\")
                    strTemp = IIf(Len(strTemp) = 0, varPath & "\", strTemp & varPath & "\")
                    If Not fso.FolderExists(strTemp) Then
                        MkDir strTemp
                        DoEvents
                    End If
                Next varPath
                strTemp = ""
            Next j
        End If
    Next i
   
    Application.ScreenUpdating = True
   
End Sub

I also coded the variable lstrow to define the the last row in Col. B as it was being set but not being used

Hope that helps.

Robert

 

[rlv01]

Another variation.

Sub MakeFolders()
    Dim xdir As String, NewDir As String
    Dim fso As Object, fldr As Object
    Dim lstrow As Long, i As Long

    Set fso = CreateObject("Scripting.FileSystemObject")

    lstrow = ActiveSheet.Cells(ActiveSheet.Rows.Count, "B").End(xlUp).Row
    Application.ScreenUpdating = False
    For i = 2 To 150                                  '<-- reads list from B2
        'change the path on the next line where you want to create the folders
        NewDir = Range("B" & i).Value
        xdir = "C:\Prontoforms\" & NewDir

        If Not fso.FolderExists(xdir) Then
            On Error Resume Next
            Set fldr = fso.CreateFolder(xdir)
            On Error GoTo 0
        Else
            Set fldr = fso.getFolder(xdir)
        End If

        If Not fldr Is Nothing Then
            If Trim(NewDir) <> "" And Not fso.FolderExists(xdir & "\Weekdays") Then
                Set fldr = fso.CreateFolder(xdir & "\Weekdays")
            End If
            If Trim(NewDir) <> "" And Not fso.FolderExists(xdir & "\Weekends") Then
                Set fldr = fso.CreateFolder(xdir & "\Weekends")
            End If
        Else
            If MsgBox("Could not create folder '" & xdir & "'", vbOKCancel) = vbCancel Then
                Exit Sub
            End If
        End If
    Set fldr = Nothing
    Next i
    Application.ScreenUpdating = True
End Sub