Create a folder and saving a worksheet as workbook in the folder

Janedb 

'   Use the register to autfill the client sheet and the create folder and saving worksheet as Workbook in new folder

Public Sub SaveFinancialDataToPlace1()
'   This procedure extracts information from specific cells in the active
'       worksheet to determine where to save the [...?] data; it then
'       determines where to save the worksheet data, and saves it there as
'       a new workbook.

    Const strPROCEDURE_NAME As String = "SaveFinancialDataToPlace1"
    Const strBASE_PATH As String = _
        "C:\Users\medcomp\Dropbox\OCEANLINK\OCEANLINKLAUNCH\Financials\Job Sheets"
    
    Dim strWorksheetName As String
    Dim strFilename      As String
    Dim strDirname       As String   'the subdirectory name
    Dim strFullDirName   As String
    Dim strPathname      As String
    Dim strResult        As String
    
    '----   Clear any prior message in the status bar.
    Application.StatusBar = ""
    
    '----   Capture here the identity of the active worksheet.
    strWorksheetName = ActiveSheet.Name
    
    '----   Retrieve values from the worksheet.
    With Worksheets(strWorksheetName)
        strDirname = .Range("C5").Value ' New directory name
        strFilename = .Range("C5").Value & .Range("H3").Value & " " _
                & .Range("C6").Text 'New file name
    End With
    If strDirname = "" Then
        Call MsgBox("Cell C5 needs to contain a subdirectory name." _
                , vbExclamation Or vbOKOnly, strPROCEDURE_NAME)
        Exit Sub
    End If
    '       (More simple validation could be included here.) #ToDo
    
    '----   Derive related values.
    strFullDirName = strBASE_PATH & "\" & strDirname
    strPathname = strFullDirName & "\" & strFilename
    
    '----   Ensure that the desired destination directory exists.
    strResult = MakeDirectoryAsNeeded(strFullDirName)
    If strResult <> "Success" Then
        Call MsgBox("Problem regarding the destination directory (" _
                & strFullDirName & "):" & vbCrLf & strResult)
        Exit Sub
    End If
    
    '----   Save the worksheet as a new workbook.
    strResult = ExportWorksheetAsWorkbook(strWorksheetName, strPathname)
    If strResult = "Success" Then
        Application.StatusBar = "Worksheet " & strWorksheetName _
                & " was successfully exported to a new workbook"
    Else
        Application.StatusBar = "Processing error!"
        Call MsgBox("Error while saving worksheet " & strWorksheetName _
                & ":" & vbCrLf & strResult, vbExclamation Or vbOKOnly _
                , strPROCEDURE_NAME)
        Exit Sub    '(to be explicit)
    End If

End Sub

Public Function MakeDirectoryAsNeeded(ByVal FullDirectoryName As String) _
        As String

    Dim strReturnValue  As String
    Dim in4ErrorCode    As Long
    Dim strErrorDescr   As String
    Dim in4Attribute    As VbFileAttribute
    
    '----   Check to see if the directory already exists.
    On Error Resume Next    '(It is likely that the next statment _
            will cause a processing error.)
    in4Attribute = GetAttr(FullDirectoryName)
    in4ErrorCode = Err.Number
    strErrorDescr = Err.Description
    On Error GoTo 0
    Select Case in4ErrorCode
        Case 0
            '...the file system object exists. Do a further check.
            If in4Attribute And vbDirectory Then
                '...the directory already exists.  Treat that as a
                '   successful execution.
                strReturnValue = "Success"
                GoTo MakeDirAsNeeded_Exit
            Else
                strReturnValue = "The file system object " _
                        & FullDirectoryName _
                        & " already exists as a regular file."
                GoTo MakeDirAsNeeded_Exit
            End If
        Case 53
            '...the directory does not exist.  Continue.
        Case Else
            strReturnValue = strErrorDescr
            GoTo MakeDirAsNeeded_Exit
    End Select
    
    '----   Attempt to create the directory; return the VBA-supplied
    '       error description if a processing error occurs.
    On Error Resume Next
    MkDir FullDirectoryName
    in4ErrorCode = Err.Number
    strErrorDescr = Err.Description
    On Error GoTo 0
    Select Case in4ErrorCode
        Case 0  'no processing error
            '...that code created the directory.
            strReturnValue = "Success"
        Case Else
            strReturnValue = strErrorDescr
    End Select
MakeDirAsNeeded_Exit:
    MakeDirectoryAsNeeded = strReturnValue
    Exit Function
End Function

Public Function ExportWorksheetAsWorkbook(ByVal WorksheetName As String _
        , ByVal ToPathname As String) As String

    Dim strReturnValue      As String
    
    '----
    On Error GoTo ExportWkshtAsWorkbook_ErrHandler
    Worksheets(WorksheetName).Copy
    ActiveWorkbook.SaveAs Filename:=ToPathname, FileFormat:=xlOpenXMLWorkbook
    ActiveWorkbook.Close SaveChanges:=False
    strReturnValue = "Success"
ExportWkshtAsWorkbook_Exit:
    ExportWorksheetAsWorkbook = strReturnValue
    Exit Function

ExportWkshtAsWorkbook_ErrHandler:
    strReturnValue = Err.Description
    Resume ExportWkshtAsWorkbook_Exit
End Function