Lost/incomplete file storage

[jlmorris]

I have written a macro to save a copy of the active workbook and reopen the original workbook so that all entries are reset to their original value for the next user. This code works well, except that once in a while the file doesn't get saved or the saved file cannot be opened. The users have not seen any error messages about this. Is there a timing issue in the code which will allow the save function to be aborted before completion or is their some other issue? Thank you.

Option Explicit
Sub SvMe()
'Saves filename as value of Last_Name First_Name plus Date_of_Birth

Dim newFile As String, fName As String, fPath As String
' Don't use "/" in date, invalid syntax
fName = Range("Last_Name").Value & " " & Range("First_Name").Value
'Change the date format to whatever you'd like, but make sure it's in quotes
newFile = fName & " " & VBA.Format$(Range("BirthDate").Value, "mm dd yyyy") & ".xlsm"
' Change directory to suit your PC, including USER NAME
fPath = "\\SignIn-PC\VaccineCenterMaster\Excel download\"
ActiveWorkbook.SaveCopyAs (fPath & newFile)
CloseMe
End Sub
Sub CloseMe()
Application.OnTime Now + TimeValue("00:00:01"), "OpenMe"
ThisWorkbook.Close False
End Sub
Sub OpenMe()
End Sub