Excel won't let macro save spreadsheet with macros - excel

Question

I've written a spreadsheet for a small company, that has several useful functions including performing the shift rotation for their full- and part-time employees, generates a list of possibly understaffed shifts and then prompts the user to save the updated file with a suggested new name. However I code it, I run into one of 2 problems:
The macro is able to save the spreadsheet without the macros - but then subsequent adjustments to the scheduling won't be reflected in the list of understaffed shifts because the macro isn't saved with the file.
The macro attempts to save the spreadsheet with the macros - but returns an error message, regardless of the parameters I pass the Workbook.SaveAs method. I would have expected that if I saved it with FileFormat=xlOpenXMLWorkbookMacroEnabled and a .xlsm suffix, then there'd be no problem. Instead I get an error message (sorry I don't have it in front of me) to the effect that Excel can't save the spreadsheet in that format. If I manually save the spreadsheet in that format, I have no problem.
I suspect this has to do with safeguards against VBA viruses, but I'm not sure how else to create the functionality I need. The office staff are not computer professionals by any stretch of the imagination, so I need to keep it simple. We also need a record of past rotations, so staff can look back on previous adjustments. At the same time, they want to be able to make adjustments to the current rotation and then re-generate the list of understaffed shifts, or clear it and start again.
I've checked similar forums and posts and the thing that usually does the trick, making sure the filename suffix is in line with the FileType parameter, doesn't seem to have worked here. Any suggestions?
Public Sub SaveSchedule()
Dim SaveName As String
Dim SaveDlg As Office.FileDialog
With Excel.ActiveWorkbook.Worksheets("Workers")
SaveName = "Shift Schedule " & Year(.Range("StartDate"))
SaveName = SaveName & "-" & Right("00" & Month(.Range("StartDate")), 2)
SaveName = SaveName & "-" & Right("00" & Day(.Range("StartDate")), 2)
SaveName = SaveName & " to " & Year(.Range("EndDate"))
SaveName = SaveName & "-" & Right("00" & Month(.Range("EndDate")), 2)
SaveName = SaveName & "-" & Right("00" & Day(.Range("EndDate")), 2)
SaveName = SaveName & ".xlsm" '".xlsx"
End With
Set SaveDlg = Application.FileDialog(msoFileDialogSaveAs)
With SaveDlg
.AllowMultiSelect = False
.ButtonName = "Save"
.InitialFileName = SaveName
.Title = "Save new shift schedule"
If .Show() Then
Excel.ActiveWorkbook.SaveAs .SelectedItems(1), xlOpenXMLWorkbookMacroEnabled ' xlOpenXMLWorkbook
Else
MsgBox SaveName & " should be saved as a new file.", vbCritical + vbApplicationModal + vbOKOnly, "New Schedule not saved."
End If
End With
End Sub

Answer 1

The issue with Application.FileDialog(msoFileDialogSaveAs) is that if you do not specify a correct filter index then it will either pick the first one
OR the one which was used last. This can be resolved by specifying .FilterIndex. For .xlsm. the filter index is 2.
Try this
With SaveDlg
.AllowMultiSelect = False
.ButtonName = "Save"
.InitialFileName = SaveName
.FilterIndex = 2 '<~~ FILTER INDEX
.Title = "Save new shift schedule"
If .Show() Then
Excel.ActiveWorkbook.SaveAs .SelectedItems(1), xlOpenXMLWorkbookMacroEnabled ' xlOpenXMLWorkbook
Else
MsgBox SaveName & " should be saved as a new file.", vbCritical + vbApplicationModal + vbOKOnly, "New Schedule not saved."
End If
End With
OTHER OPTIONS
OPTION 1 : Directly save the file
Dim SaveName As String
With Excel.ActiveWorkbook.Worksheets("Workers")
SaveName = "Shift Schedule " & Year(.Range("StartDate"))
SaveName = SaveName & "-" & Right("00" & Month(.Range("StartDate")), 2)
SaveName = SaveName & "-" & Right("00" & Day(.Range("StartDate")), 2)
SaveName = SaveName & " to " & Year(.Range("EndDate"))
SaveName = SaveName & "-" & Right("00" & Month(.Range("EndDate")), 2)
SaveName = SaveName & "-" & Right("00" & Day(.Range("EndDate")), 2)
SaveName = SaveName & ".xlsm" '".xlsx"
End With
Excel.ActiveWorkbook.SaveAs Filename:=SaveName, FileFormat:=xlOpenXMLWorkbookMacroEnabled
OPTION 2 : Let user only choose a folder
In this option user will not be able to modify the file name and extension. They can only choose the Save As folder.
Option Explicit
Sub Sample()
Dim SaveName As String
Dim Extn As String
Dim FlFormat As Integer
With Excel.ActiveWorkbook.Worksheets("Workers")
SaveName = "Shift Schedule " & Year(.Range("StartDate"))
SaveName = SaveName & "-" & Right("00" & Month(.Range("StartDate")), 2)
SaveName = SaveName & "-" & Right("00" & Day(.Range("StartDate")), 2)
SaveName = SaveName & " to " & Year(.Range("EndDate"))
SaveName = SaveName & "-" & Right("00" & Month(.Range("EndDate")), 2)
SaveName = SaveName & "-" & Right("00" & Day(.Range("EndDate")), 2)
SaveName = SaveName
End With
'~~> File extenstion. I have shown only for 2
'~~> Tweak for rest
Extn = ".xlsm" '".xlsx"
If Extn = ".xlsm" Then
FlFormat = xlOpenXMLWorkbookMacroEnabled
ElseIf Extn = ".xlsx" Then
FlFormat = xlOpenXMLWorkbook
End If
'~~> Folder Browser
Dim Ret As Variant
Ret = BrowseForFolder
If Ret = False Then Exit Sub
Dim Filepath As String
Filepath = Ret
If Right(Filepath, 1) <> "\" Then Filepath = Filepath & "\"
SaveName = Filepath & SaveName & Extn
Excel.ActiveWorkbook.SaveAs Filename:=SaveName, FileFormat:=FlFormat
End Sub
Function BrowseForFolder(Optional OpenAt As Variant) As Variant
Dim ShellApp As Object
Set ShellApp = CreateObject("Shell.Application"). _
BrowseForFolder(0, "Please choose a folder", 0, OpenAt)
On Error Resume Next
BrowseForFolder = ShellApp.self.Path
On Error GoTo 0
Set ShellApp = Nothing
Select Case Mid(BrowseForFolder, 2, 1)
Case Is = ":"
If Left(BrowseForFolder, 1) = ":" Then GoTo CleanExit
Case Is = "\"
If Not Left(BrowseForFolder, 1) = "\" Then GoTo CleanExit
Case Else
GoTo CleanExit
End Select
Exit Function
CleanExit:
BrowseForFolder = False
End Function

Answer 2

SaveAs Dialog
Public Sub SaveSchedule()
Const PROC_TITLE As String = "Save New Shift Schedule"
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim ws As Worksheet: Set ws = wb.Worksheets("Workers")
Dim SaveName As String
With ws
SaveName = "Shift Schedule " & Format(.Range("StartDate"), "YYYY-MM-DD")
SaveName = SaveName & " to " & Format(.Range("EndDate"), "YYYY-MM-DD")
SaveName = SaveName & ".xlsm"
End With
Dim SaveDlg As Office.FileDialog
Set SaveDlg = Application.FileDialog(msoFileDialogSaveAs)
With SaveDlg
.AllowMultiSelect = False
.ButtonName = "SaveAs"
.FilterIndex = 2 ' .xlsm
.InitialFileName = SaveName
.Title = PROC_TITLE
Dim FilePath As String
If .Show Then
FilePath = .SelectedItems(1)
If StrComp(Right(FilePath, 5), ".xlsm", vbTextCompare) = 0 Then
Application.DisplayAlerts = False ' overwrite, no confirmation
wb.SaveAs FilePath, xlOpenXMLWorkbookMacroEnabled
Application.DisplayAlerts = True
Else ' not '.xlsm'
MsgBox "The file needs to be saved with an '.xlsm' extension." _
& vbLf & "File not saved.", _
vbCritical + vbApplicationModal, PROC_TITLE
End If
Else ' canceled
MsgBox SaveName & " not saved.", _
vbCritical + vbApplicationModal, PROC_TITLE
End If
End With
End Sub