VBA to save worksheet with a specific name - vba

Question

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.

Answer 1

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