BeforeSave loops and workbook closes

Question

I am attempting to save a "copy" of a workbook by forcing a set path and filename. The following code does two things that I would like to avoid. First, the "message" is displayed twice. Why is this occurring and how can I prevent it? Second, the workbook closes after the save completes, even if I only click on the save icon. I need the workbook to stay open unless the red "x" is pressed. Here is the code:

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean) 

Const Function_Area = "Benefits" 

Dim Full_Filename As String 
Dim Temp_Filename_Prefix As String 
Dim Temp_Filename_Suffix As String 
Dim Temp_Path As String 
Dim Error_Check As Boolean 
Dim End_Msg As Variant 
Dim Temp_Object As Object 

Set Temp_Object = CreateObject("WScript.Shell") 

With Temp_Object 
    Temp_Path = .SpecialFolders("Desktop") & "\" 
End With 

If Range("REVIEW_TYPE").Value = "Prototype Review" Then 
    Temp_Filename_Prefix = Range("CUSTOMER_NAME").Value & Function_Area & "_PROTO_" 
End If 
If Range("REVIEW_TYPE").Value = "Final Review" Then 
    Temp_Filename_Prefix = Range("CUSTOMER_NAME").Value & Function_Area & "_FINAL_" 
End If 
If Range("REVIEW_TYPE").Value = "Compliance Review" Then 
    Temp_Filename_Prefix = Range("CUSTOMER_NAME").Value & Function_Area & "_COMPLIANCE_" 
End If 

Temp_Filename_Suffix = Format(Date, "yyyymmdd") 
Temp_Filename_Suffix = Temp_Filename_Suffix & "C" 

Full_Filename = Temp_Path & Temp_Filename_Prefix & Temp_Filename_Suffix 

End_Msg = "This file has been saved to your DESKTOP as " & Chr(13) & Chr(10) & _ 
Full_Filename 
End_Msg = MsgBox(End_Msg, vbInformation, "FILE SAVED") 

' Save file to Desktop

ActiveWorkbook.SaveAs Filename:=Full_Filename, FileFormat:=52 
ThisWorkbook.Saved = True 

End Sub

Thank you for any guidance you can provide.

Answer 1

just a couple of suggestions to clean up the code

you can use this in place of the three if-then statements, just to unclutter the code

    Dim prfx As String

    Select Case Range("REVIEW_TYPE").Value

        Case "Prototype Review":   prfx = "_PROTO_"
        Case "Final Review":       prfx = "_FINAL_"
        Case "Compliance Review":  prfx = "_COMPLIANCE_"

        Case Else:                 ' put code here, for not any of above

    End Select

    Temp_Filename_Prefix = Range("CUSTOMER_NAME").Value & Function_Area & prfx

also shorten the following

With Temp_Object 
    Temp_Path = .SpecialFolders("Desktop") & "\" 
End With

just use

Temp_Path = Temp_Object.SpecialFolders("Desktop") & "\"

also replace & Chr(13) & Chr(10) & with & vbCrLf & or with & vbNewLine &