Save A Workbook Using The File Save Dialog Box
The following code will prompt the user for a target directory, and save a workbook with the name that the user enters into the dialog box. The example below saves the workbook as an xlsm file.
For all the possible formats in the Workbook.SaveAs FileFormat:=, see this article:
Program Code
Option Explicit
Private Declare Function GetUserName Lib "advapi32.dll" Alias "GetUserNameA" (ByVal lpBuffer As String, nSize As Long) As Long
Public Sub GetTemplatePath()
Dim strPathToJobInfoTemplate As String
Dim strJobInfoWorkbookToSave As Variant
Dim wkbJobInfoWorkbook As Workbook
' *************************************************************
' Construct The Path To The Job Info Template
' *************************************************************
strPathToJobInfoTemplate = "C:\Users\" & UserNameWindows() & "\Documents\JobInfoTemplate\JobInfoTemplate.xlsm"
' *************************************************************
' Open The Template
' *************************************************************
On Error GoTo NoTemplateFound
Workbooks.Open strPathToJobInfoTemplate
On Error GoTo 0
Set wkbJobInfoWorkbook = ActiveWorkbook
' *************************************************************
' Open A Dialog Box For The User To Save The File
' *************************************************************
strJobInfoWorkbookToSave = Application.GetSaveAsFilename("", _
"Excel Files (*.xlsm), *.xlsm", , "Save Job Info Sheet")
' *************************************************************
' Make Sure A Valid Name and Path Were Selected
' *************************************************************
If strJobInfoWorkbookToSave = False Then
MsgBox ("You Did Not Select A File Name For Export" & vbCrLf & _
"Please Start Over")
Application.ScreenUpdating = True
Exit Sub
End If
' *************************************************************
' Activate This Workbook
' *************************************************************
ThisWorkbook.Activate
' *************************************************************
' Save the Job Info Workbook
' *************************************************************
wkbJobInfoWorkbook.SaveAs Filename:=strJobInfoWorkbookToSave, _
FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
wkbJobInfoWorkbook.Close SaveChanges:=False
Exit Sub
NoTemplateFound:
MsgBox ("File JobInfoTemplate.xlsm Not Found in Path:" & vbCrLf & _
strPathToJobInfoTemplate)
Exit Sub
End Sub
Function UserNameWindows() As String
Dim lngLen As Long
Dim strBuffer As String
Const dhcMaxUserName = 255
strBuffer = Space(dhcMaxUserName)
lngLen = dhcMaxUserName
If CBool(GetUserName(strBuffer, lngLen)) Then
UserNameWindows = Left$(strBuffer, lngLen - 1)
Else
UserNameWindows = ""
End If
End Function
' $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
' Method 2 - Using Application.FileDialog
' $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
Private Sub UseFileDialogSave()
Dim dlgSaveAs As FileDialog
strFilePathToSave = ""
Set dlgSaveAs = Application.FileDialog(msoFileDialogSaveAs)
With dlgSaveAs
.Show
If .SelectedItems.Count < 1 Then
Exit Sub
End If
strFilePathToSave = .SelectedItems(1)
End With
End Sub
' $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
' Additional Example - See Save Portion - This Only Gets The Path And Doesn't Save As Above
' $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
Option Explicit
Dim varFileName As Variant
Public Sub FileOpenAndSave()
' ************************************************************************
' Using The Application.GetOpenFilename Function
' ************************************************************************
varFileName = Application.GetOpenFilename(FileFilter:="Excel File (*.xls),*.xls", FilterIndex:=1, Title:="Choose Excel File To Open")
Call DisplayFileResults
varFileName = Application.GetOpenFilename(FileFilter:="Text Files (*.txt), *.txt, " & _
"Add-In Files (*.xla), *.xla, " & _
"Excel Files (*.xls; *.xlsx),*.xls;*.xlsx", FilterIndex:=2, Title:="Enter A FileName To Open")
Call DisplayFileResults
' ************************************************************************
' Using The Application.GetSaveAsFilename Function
' ************************************************************************
varFileName = Application.GetSaveAsFilename(FileFilter:="Excel File (*.xls),*.xls", FilterIndex:=1, Title:="Enter A FileName To Save")
Call DisplayFileResults
varFileName = Application.GetSaveAsFilename(FileFilter:="Excel Files (*.xls; *.xlsx),*.xls;*.xlsx", FilterIndex:=1, Title:="Enter A FileName To Save")
Call DisplayFileResults
varFileName = Application.GetSaveAsFilename(FileFilter:="Visual Basic Files (*.bas; *.txt),*.bas;*.txt", FilterIndex:=1, Title:="Enter A FileName To Save")
Call DisplayFileResults
varFileName = Application.GetSaveAsFilename(FileFilter:="Text Files (*.txt), *.txt, Add-In Files (*.xla), *.xla", FilterIndex:=2, Title:="Enter A FileName To Save")
Call DisplayFileResults
varFileName = Application.GetSaveAsFilename(FileFilter:="Text Files (*.txt), *.txt, " & _
"Add-In Files (*.xla), *.xla, " & _
"Excel Files (*.xls; *.xlsx),*.xls;*.xlsx", FilterIndex:=2, Title:="Enter A FileName To Save")
Call DisplayFileResults
End Sub
Private Sub DisplayFileResults()
If varFileName <> False Then
MsgBox "Save As Filename Is " & varFileName
Else
MsgBox ("You Did Not Provide A Valid Name")
End If
End Sub