Excel won't let macro save spreadsheet with macros

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:

1. 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.
2. 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

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

Answer 2

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