jamajam
08-16-2011, 02:14 AM
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?
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
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?
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