CODEWITHSUNDEEP
vbaexcel
Neil Capper
Neil Capper

Reputation: 49

VBA to save worksheet with a specific name

Hi probably a simple answer but im new to VBA.

I have a worksheet in a workbook. This worksheet has a specific reference in cell A1 which changes each time its used. It is basically an order number and formatted 03 01 15. The next will be 03 02 15, then 03 03 15 and so on.

What I want to do is to use VBA to save the sheet in a new workbook in my orders folder, and for the new workbook to be called the order number.

I can use the record macro function to get the basic VBA to copy the sheet, open a new workbook, paste the values and close the workbook, but im struggling with getting the name right. Each new workbook will have a different name based on the order number.

Any help would be appriciated.

Upvotes: 2

Views: 2653

Answers (1)

VBasic2008
VBasic2008

Reputation: 54948

Export a Worksheet to a Folder

Sub ExportWorksheetToFolder()
    Const ProcTitle As String = "Export Worksheet to Folder"
    
    ' Define constants.
    
    Const DESTINATION_SUBFOLDER_NAME As String = "Orders"
    Const DESTINATION_FILE_NAME_ADDRESS As String = "A1"
    
    ' Reference the worksheet.
    
    Dim ws As Worksheet: Set ws = ActiveSheet
    ' Instead, improve with e.g.
    'Dim ws As Worksheet: Set ws = ThisWorkbook.Worksheets("Sheet1")
    
    ' Build the destination file path ('dFilePath').
    
    ' Since we will be saving an unsaved workbook (file), by not supplying
    ' the file extension and the parameter for the FileFormat argument
    ' of the SaveAs method, the new workbook will be saved
    ' with the .xlsx extension (losing any code in it) or, 
    ' for Office prior to version 2007, with the .xls extension.
    
    Dim pSep As String: pSep = Application.PathSeparator

    ' If the cell is blank, we don't have a name.
    Dim dBaseName As String
    dBaseName = CStr(ws.Range(DESTINATION_FILE_NAME_ADDRESS))
    If Len(dBaseName) = 0 Then
        MsgBox "Cell " & UCase(DESTINATION_FILE_NAME_ADDRESS) & " is blank.", _
            vbCritical, ProcTitle
        Exit Sub
    End If
    
    ' If the workbook has never been saved, its path is "".
    Dim wbPath As String: wbPath = ws.Parent.Path
    If Len(wbPath) = 0 Then
        MsgBox "You need to save the workbook to use this procedure.", _
            vbCritical, ProcTitle
        Exit Sub
    End If
    
    ' Create the subfolder if it doesn't exist.
    Dim dFolderPath As String: dFolderPath = wb.Path _
        & pSep & DESTINATION_SUBFOLDER_NAME & pSep
    If Len(Dir(dFolderPath, vbDirectory)) = 0 Then MkDir dFolderPath
    
    Dim dFilePath As String: dFilePath = dFolderPath & dBaseName
    
    ' Copy.
    
    ws.Copy ' copies the worksheet to a new workbook
    
    ' Save.
    
    Dim MsgString As String
    
    With Workbooks(Workbooks.Count) ' reference the new workbook
        Application.DisplayAlerts = False
        ' 1. save without macros ... without confirmation
        ' 2. overwrite existing file ... without confirmation
            On Error Resume Next
                .SaveAs dFilePath
                If Err.Number <> 0 Then ' invalid file name, file open...
                    MsgString = "Run-time error '" & Err.Number & "':" _
                        & vbLf & vbLf & Err.Description _
                        & vbLf & vbLf & "Could not save as '" & dFilePath & "'."
                End If
            On Error GoTo 0
        Application.DisplayAlerts = True
        .Close SaveChanges:=False
    End With

    ' Inform.

    If Len(MsgString) = 0 Then
        MsgBox "Worksheet exported.", vbInformation, ProcTitle
    Else
        MsgBox MsgString, vbCritical, ProcTitle
    End If

End Sub

Upvotes: 2

Related Questions