Solved: Workbook_beforesave saves file twice

I need the Workbook_BeforeSave event to run to do some validation checks but I don't want it to automatically save the workbook.

I have it set so that the filename is automatically generated from 3 cells. This all works ok until I click the 'SaveAs' button on the toolbar. The dialog box pops up with the new filename correctly completed but in the background I can see that the exact same filename is already there!

Consequently, when I click 'Save' I get 'file already exists, replace?'

I just click 'yes' to overwrite and everything gets saved fine but this shouldn't happen & I obviously have something wrong in the code. I'm a novice and have just cobbled bits & pieces of code together and have got something somewhere wrong.

Please can someone help?


[vba]Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Dim Start As Boolean
Dim Rng1 As Range, Rng3 As Range, Rng4 As Range
Dim sRange1 As String
Dim sRange2 As String
Dim sRange3 As String
Dim sFullPath As String
Dim Prompt As String, RngStr As String
Dim Cell As Range
'set your ranges here
'Rng1 is on sheet "Group Profile" and cells B5 through B14
'Cell F1, A range of F5 through F7 etc. you can change these to
'suit your needs.
Set Rng1 = Sheets("Invoice").Range("AC22")
Set Rng3 = Sheets("Invoice").Range("H30")
Set Rng4 = Sheets("Invoice").Range("J25")
'message is returned if there are blank cells
Prompt = "Please check your data ensuring all required " & _
"cells are complete." & vbCrLf & "you will not be able " & _
"to close or save the workbook until the form has been filled " & _
"out completely. " & vbCrLf & vbCrLf & _
"The following cells are incomplete and have been highlighted yellow:" _
& vbCrLf & vbCrLf
Start = True
'highlights the blank cells

For Each Cell In Rng1
If Cell.Value = vbNullString Then
Cell.Interior.ColorIndex = 6 '** color yellow
If Start Then RngStr = RngStr & Cell.Parent.Name & vbCrLf
Start = False
RngStr = RngStr & Cell.Address(False, False) & ", "
Else
Cell.Interior.ColorIndex = 0 '** no color
End If
Next
If RngStr <> "" Then RngStr = Left$(RngStr, Len(RngStr) - 2)
Start = True
If RngStr <> "" Then RngStr = RngStr & vbCrLf & vbCrLf
For Each Cell In Rng3
If Cell.Value = vbNullString Then
Cell.Interior.ColorIndex = 6 '** color yellow
If Start Then RngStr = RngStr & Cell.Parent.Name & vbCrLf
Start = False
RngStr = RngStr & Cell.Address(False, False) & ", "
Else
Cell.Interior.ColorIndex = 0 '** no color
End If
Next
If RngStr <> "" Then RngStr = Left$(RngStr, Len(RngStr) - 2)
Start = True
If RngStr <> "" Then RngStr = RngStr & vbCrLf & vbCrLf
For Each Cell In Rng4
If Cell.Value = vbNullString Then
Cell.Interior.ColorIndex = 6 '** color yellow
If Start Then RngStr = RngStr & Cell.Parent.Name & vbCrLf
Start = False
RngStr = RngStr & Cell.Address(False, False) & ", "
Else
Cell.Interior.ColorIndex = 0 '** no color
End If
Next
If RngStr <> "" Then RngStr = Left$(RngStr, Len(RngStr) - 2)
If RngStr <> "" Then
MsgBox Prompt & RngStr, vbCritical, "Incomplete Data"
Cancel = True
Else
'saves the changes before closing
sRange1 = ActiveSheet.Range("AC22")
sRange2 = ActiveSheet.Range("H30")
sRange3 = ActiveSheet.Range("J25")
sFullPath = sRange1 + "." + sRange2 + "." + sRange3 + ".xls"
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs Filename:="\\CompName\SharedDocs\LAS invoices\" & sFullPath
Cancel = False
End If

Set Rng1 = Nothing
Set Rng3 = Nothing
Set Rng4 = Nothing

End Sub

[/vba]

Unless you set Cancel = True (which you only do in one branch of your code), the original save action that you triggered will still occur in addition to the saveas you specify.
Additionally, if you are going to save a workbook in a BeforeSave event, you should disable events before you do so and reset them afterwards:
[vba]
On error resume next
Application.Enableevents = False
ActiveWorkbook.SaveAs Filename:="\\CompName\SharedDocs\LAS invoices\"
& sFullPath
Application.Enableevents = True
On error goto 0[/vba]

Many thanks for your help & your prompt reply.

That does indeed solve the duplicate problem as it simply saves the file (with the correct name) but unfortunately no dialog box pops up.

I would still like to see the dialog box pop up (with the filename prefilled from cells) so that other users can see the filename that it's going to be saved as.
This would allow a visual check that the 'name' etc is spelt correctly and they would also have the option to save or cancel.

Can this be done?

Application.GetSaveAsFilename lets the user choose a name and location. You can preload them where you want with ChDir. If you want to be elaborate, you might perform your own edits on what you allow as to filename and locations, a la[vba]Dim sDestPath As String
sDestPath = Application.GetSaveAsFilename(, , , Title:="Set destination dir")
sDestPath = Left(sDestPath, InStrRev(sDestPath, "\") - 1) ' strip all following final \, so it's a dir name only[/vba]and mess with the directory name and such, maybe later going
Application.SaveAs sDestPath & sMyFileName

Or just[vba]sOutFileName = Application.GetSaveAsFilename(, , , Title:="Set destination file")
Application.SaveAs sOutFileName[/vba]

Sorry I didn't reply sooner but we've been busy at work.

Thanks Antigates, I tried the code you gave. The dialog box comes up but I lost the prefilled filename (taken from certain cells).

To be honest, I'm just a novice and don't really know what I'm doing. I put your code in between Aflatoon's code, was that right?

I've no idea what ChDir is or how to use it but we're on a network and am using UNC to store the saved files on the main computer if that helps.

Just to summarise: Aflatoon's code prevents the double save but I don't see the dialog box and Antigates brings up the dialog box but I don't get the prefilled filename.

I guess what I need is a combination of the two but this is beyond my capabilities, I'm afraid so any help would be greatfully received. Many thanks

Please test this version of your code:
[vba]

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Dim Start As Boolean
Dim Rng1 As Excel.Range
Dim Rng3 As Excel.Range
Dim Rng4 As Excel.Range
Dim Cell As Excel.Range
Dim sRange1 As String
Dim sRange2 As String
Dim sRange3 As String
Dim sFullPath As String
Dim Prompt As String
Dim RngStr As String
Dim sSavePath As String

' cancel default action, since this code will either not save, or will take care of the save as
Cancel = True

On Error GoTo error_handler

'set your ranges here
'Rng1 is on sheet "Group Profile" and cells B5 through B14
'Cell F1, A range of F5 through F7 etc. you can change these to
'suit your needs.
Set Rng1 = Sheets("Invoice").Range("AC22")
Set Rng3 = Sheets("Invoice").Range("H30")
Set Rng4 = Sheets("Invoice").Range("J25")

'message is returned if there are blank cells
Prompt = "Please check your data ensuring all required " & _
"cells are complete." & vbCrLf & "you will not be able " & _
"to close or save the workbook until the form has been filled " & _
"out completely. " & vbCrLf & vbCrLf & _
"The following cells are incomplete and have been highlighted yellow:" _
& vbCrLf & vbCrLf
Start = True
'highlights the blank cells

For Each Cell In Rng1
If Cell.Value = vbNullString Then
Cell.Interior.ColorIndex = 6 '** color yellow
If Start Then RngStr = RngStr & Cell.Parent.Name & vbCrLf
Start = False
RngStr = RngStr & Cell.Address(False, False) & ", "
Else
Cell.Interior.ColorIndex = xlColorIndexNone '** no color
End If
Next
If RngStr <> "" Then RngStr = Left$(RngStr, Len(RngStr) - 2)
Start = True
If RngStr <> "" Then RngStr = RngStr & vbCrLf & vbCrLf
For Each Cell In Rng3
If Cell.Value = vbNullString Then
Cell.Interior.ColorIndex = 6 '** color yellow
If Start Then RngStr = RngStr & Cell.Parent.Name & vbCrLf
Start = False
RngStr = RngStr & Cell.Address(False, False) & ", "
Else
Cell.Interior.ColorIndex = 0 '** no color
End If
Next
If RngStr <> "" Then RngStr = Left$(RngStr, Len(RngStr) - 2)
Start = True
If RngStr <> "" Then RngStr = RngStr & vbCrLf & vbCrLf
For Each Cell In Rng4
If Cell.Value = vbNullString Then
Cell.Interior.ColorIndex = 6 '** color yellow
If Start Then RngStr = RngStr & Cell.Parent.Name & vbCrLf
Start = False
RngStr = RngStr & Cell.Address(False, False) & ", "
Else
Cell.Interior.ColorIndex = 0 '** no color
End If
Next
If RngStr <> "" Then RngStr = Left$(RngStr, Len(RngStr) - 2)
If RngStr <> "" Then
MsgBox Prompt & RngStr, vbCritical, "Incomplete Data"
Else
'saves the changes before closing
sRange1 = ActiveSheet.Range("AC22")
sRange2 = ActiveSheet.Range("H30")
sRange3 = ActiveSheet.Range("J25")
sFullPath = sRange1 + "." + sRange2 + "." + sRange3 + ".xls"

' disable events so that we do not trigger the BeforeSave event again
With Application
.DisplayAlerts = False
.EnableEvents = False
End With
' prompt user for save path
sSavePath = Application.GetSaveAsFilename(InitialFileName:="\\CompName\SharedDocs\LAS invoices\" & sFullPath, fileFilter:="Excel Files (*.xls), *.xls", Title:="Save file")
If sSavePath <> "False" Then ActiveWorkbook.SaveAs Filename:=sSavePath
End If

Set Rng1 = Nothing
Set Rng3 = Nothing
Set Rng4 = Nothing


leave:
Application.EnableEvents = True
Exit Sub

error_handler:
MsgBox Err.Number & " - " & Err.Description
Resume leave
End Sub
[/vba]

Thank you very much, Aflatoon, it works like a charm-exactly what I wanted.

I've compared my code to the changes you've made and I sort of understand what's going on but I don't think I would ever have worked it out.

Again many thanks for taking the time and trouble to solve this for me.
:beerchug:

Aflatoon, thank you for following up on that GetSaveAsFilename code. It's clear that you went to considerable time and trouble to integrate into and enhance his/her existing code. I've been quite short on time and, looking at this and some of your other posts, I appreciate your contribution.