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

[Janedb]

Hi, I have two tabs, one is the register and the other the template. I need a VBA to click a button on the register to use the template to create a new worksheet then create the folder to save the worksheet as new workbook in the newly created folder. (it is currently written for pdf which should be change to excel format)

See sample attached please if anyone can help.

[#2 · Accepted solution]

@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

[#3]

Thank you Hans

[#4]

@Hans Vogelaar is there a way to change the link to accommodate multiple users from different locations to save to the save drive? If I set it to my name Jane, then Marc cant use it because he gets an error because it is pointing to my user.

C:\Users\Jane\Dropbox\OCEANLINK\OCEANLINKLAUNCH\Financials\Job Sheets

C:\Users\user?\Dropbox\OCEANLINK\OCEANLINKLAUNCH\Financials\Job Sheets

[#5]

@Janedb 

Change the lines

    Const strBASE_PATH As String = _
        "C:\Users\medcomp\Dropbox\OCEANLINK\OCEANLINKLAUNCH\Financials\Job Sheets"

to

    Dim strBASE_PATH As String
    strBASE_PATH = Environ("UserProfile") & _
        "\Dropbox\OCEANLINK\OCEANLINKLAUNCH\Financials\Job Sheets"

[#6]

Thank you!!