VBA to create folder if it doesn't exist

[jondavis1987]

Below I have a vba to say a worksheet in a certain folder that changes. The folder is jname in the vba. How do i make it where it will create a folder with the name that jname. For instance the value in A!B4 could be 23727 and if a folder that is named 23727 doesn't exist it would create one at the proper location.

Sub Export_Cores_as_PDF()

Dim FolderPath As String
Dim fName As String
Dim jName As String

fName = Sheets("A").Range("A!G8").Value
jName = Sheets("A").Range("A!B4").Value
FolderPath = "C:\Users\" & Environ("username") & "\Dropbox\Quality Control\Jobs\" & jName & "\"


       
    Sheets(Array("Core Report", "Joints")).Select
    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=FolderPath & fName, _
        openafterpublish:=False, ignoreprintareas:=False
    
MsgBox "All PDF's have been successfully exported."

End Sub

 

[jkpieterse]

This code gives you a start I expect (does not work with UNC paths):

Option Explicit

Sub test()
    If CheckPath("c:\test") Then
        MsgBox "Folder is there (or has been created)"
    Else
        MsgBox "Folder not found and could not be created"
    End If
End Sub

Function CheckPath(sPath As String) As Boolean
    On Error GoTo locErr
    If Dir(sPath, vbDirectory) = "" Then
        If MsgBox( _
            "The path : " & vbNewLine & sPath & vbNewLine & _
            "does not exist, create it ?", vbQuestion + vbYesNo, _
            "Create a Path") = vbYes Then
            AddPath sPath
            If CheckPath(sPath) Then
                CheckPath = True
            Else
                CheckPath = False
            End If
        End If
    Else
        CheckPath = True
    End If
TidyUp:
    Exit Function
locErr:
    If MsgBox(Err.Description, vbAbortRetryIgnore + vbCritical, _
        "Error " & Err.Number) = vbRetry Then
        Resume
    Else
        Resume TidyUp
    End If
End Function

Sub AddPath(sPath As String)
    Static bErrMsg As Boolean
    On Error GoTo locErr
    Dim sTemp As String
    Dim iPos As Integer
    Dim sCurdir As String
    Dim sSeparator As String
    sSeparator = Application.PathSeparator
    sCurdir = CurDir
    ChDrive sPath
    If Right(sPath, 1) <> sSeparator Then
        sPath = sPath & sSeparator
    End If
    If Dir(sPath, vbDirectory) <> "" Then GoTo TidyUp
    iPos = 3
    While iPos > 0
        iPos = InStr(iPos + 1, sPath, sSeparator)
        sTemp = Left(sPath, iPos)
        If sTemp = "" Then GoTo TidyUp
        If Dir(sTemp, vbDirectory) = "" Then
            MkDir sTemp
        Else
            ChDir sTemp
        End If
    Wend
TidyUp:
    If sCurdir <> CurDir Then
        ChDrive sCurdir
        ChDir sCurdir
    End If
    bErrMsg = False
    Exit Sub
locErr:
    If Err.Number = 76 Or Err.Number = 68 Then
        If Not bErrMsg Then
            MsgBox "Error: Path " & sCurdir & _
                " does not exist, could not restore default folder.", _
                vbCritical + vbOKOnly, "Add A Path"
            '76: Current dir seems to have disappeared!
            '68: drive hasbeen removed
            bErrMsg = True
        End If
        Resume Next
    End If
    If MsgBox(Err.Description, vbAbortRetryIgnore + vbCritical, _
        "Error " & Err.Number) = vbRetry Then
        Resume
    Else
        Resume TidyUp
    End If
End Sub

 

[jondavis1987]

This code gives you a start I expect (does not work with UNC paths):

Option Explicit

Sub test()
    If CheckPath("c:\test") Then
        MsgBox "Folder is there (or has been created)"
    Else
        MsgBox "Folder not found and could not be created"
    End If
End Sub

Function CheckPath(sPath As String) As Boolean
    On Error GoTo locErr
    If Dir(sPath, vbDirectory) = "" Then
        If MsgBox( _
            "The path : " & vbNewLine & sPath & vbNewLine & _
            "does not exist, create it ?", vbQuestion + vbYesNo, _
            "Create a Path") = vbYes Then
            AddPath sPath
            If CheckPath(sPath) Then
                CheckPath = True
            Else
                CheckPath = False
            End If
        End If
    Else
        CheckPath = True
    End If
TidyUp:
    Exit Function
locErr:
    If MsgBox(Err.Description, vbAbortRetryIgnore + vbCritical, _
        "Error " & Err.Number) = vbRetry Then
        Resume
    Else
        Resume TidyUp
    End If
End Function

Sub AddPath(sPath As String)
    Static bErrMsg As Boolean
    On Error GoTo locErr
    Dim sTemp As String
    Dim iPos As Integer
    Dim sCurdir As String
    Dim sSeparator As String
    sSeparator = Application.PathSeparator
    sCurdir = CurDir
    ChDrive sPath
    If Right(sPath, 1) <> sSeparator Then
        sPath = sPath & sSeparator
    End If
    If Dir(sPath, vbDirectory) <> "" Then GoTo TidyUp
    iPos = 3
    While iPos > 0
        iPos = InStr(iPos + 1, sPath, sSeparator)
        sTemp = Left(sPath, iPos)
        If sTemp = "" Then GoTo TidyUp
        If Dir(sTemp, vbDirectory) = "" Then
            MkDir sTemp
        Else
            ChDir sTemp
        End If
    Wend
TidyUp:
    If sCurdir <> CurDir Then
        ChDrive sCurdir
        ChDir sCurdir
    End If
    bErrMsg = False
    Exit Sub
locErr:
    If Err.Number = 76 Or Err.Number = 68 Then
        If Not bErrMsg Then
            MsgBox "Error: Path " & sCurdir & _
                " does not exist, could not restore default folder.", _
                vbCritical + vbOKOnly, "Add A Path"
            '76: Current dir seems to have disappeared!
            '68: drive hasbeen removed
            bErrMsg = True
        End If
        Resume Next
    End If
    If MsgBox(Err.Description, vbAbortRetryIgnore + vbCritical, _
        "Error " & Err.Number) = vbRetry Then
        Resume
    Else
        Resume TidyUp
    End If
End Sub

Thank you