I have written the SUB below - when I clicked [X] it is working all right - but the dialog box is appearing twice before saving. When I used the SAVE Icon - it does the same thing BUT there's a prompt that say "Excel has stop working" - when I ignore the prompt - it saves the file.
I am trying to save the file with a designated name.
Is this procedure even correct at all?
many many thanks
I am trying to save the file with a designated name.
Is this procedure even correct at all?
many many thanks
Code:
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Dim file_name As Variant
Dim FName As String
On Error Resume Next
Application.DisplayAlerts = False
nyr = Format(Sheets("FS").Range("A2"), "yyyy")
nfty = " for the year " & nyr & ".xlsm"
FName = Replace(ThisWorkbook.FullName, ".xlsm", "") & nfty
If ExactWordInString(FName, " for the year ") <> 0 Then
FName = Replace(ThisWorkbook.FullName, ".xlsm", "")
End If
file_name = Application.GetSaveAsFilename(FName, _
FileFilter:="Excel Files,*.xlsm,All Files,*.*", _
Title:="Save As File Name")
If file_name = False Then
Cancel = True
Else
If LCase$(Right$(file_name, 5)) <> ".xlsm" Then
file_name = file_name & ".xlsm"
End If
ActiveWorkbook.SaveAs Filename:=file_name
End If
On Error GoTo 0
Application.DisplayAlerts = True
Application.Quit
End Sub
Function ExactWordInString(Text As String, Word As String) As Boolean
ExactWordInString = " " & UCase(Text) & " " Like "*[!A-Z]" & UCase(Word) & "[!A-Z]*"
End Function
Last edited:
