BENSON
06-13-2008, 06:02 AM
The code below works fine, it does not allow a user to close the spread sheet untill specific data has been entered.I would like to modify the code so the the user can close the spread sheet if they choose, after the message box advises them of the in complete data (I will change the message box information )
Thanks
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Dim wSheet As Worksheet
Application.ScreenUpdating = False
For Each wSheet In Worksheets
Next
Dim Arr, Dy As Long
Dim Rng As Range, cell As Range
Dim Start As Boolean
Dim Prompt As String, RngStr As String
Prompt = "PLEASE CHECK YOUR DATA ENSURING ALL REQUIRED " & _
"CELLS ARE COMPLETE." & vbCrLf & "YOU WILL NOT BE ABLE " & _
"TO CLOSE OR SAVE THE DAILY REPORT UNTIL ALL THE REQUIRED CELLS ARE FILLED " & _
"OUT COMPLETELY. " & vbCrLf & vbCrLf & _
"THE CELLS LISTED BELOW CONTAIN NO DATA AND HAVE BEEN HIGHLIGHTED RED:" _
& vbCrLf & vbCrLf
Arr = Array("TUES", "WED", "THURS", "FRI", "SAT", "SUN", "MON")
For Dy = 0 To Weekday(Now, vbTuesday) - 1
With Worksheets(Format(Weekday(Date), "ddd"))
Start = True
Set Rng = TgtRange(.Name)
'highlights the blank cells
For Each cell In Rng
If cell.Value = vbNullString Then
cell.Interior.ColorIndex = 3 '** color red
If Start Then RngStr = RngStr & cell.Parent.Name & vbCrLf
Start = False
RngStr = RngStr & cell.Address(False, False) & " , "
Else
cell.Interior.ColorIndex = 36 '** Light Yellow
End If
Next
If RngStr <> "" Then RngStr = Left$(RngStr, Len(RngStr) - 0)
End With
Next
If RngStr <> "" Then
MsgBox Prompt & RngStr, vbCritical, "Incomplete Data"
Cancel = True
Else
'saves the changes before closing
ThisWorkbook.Save
Cancel = False
End If
For Each wSheet In Worksheets
Next
Application.ScreenUpdating = True
End Sub
Thanks
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Dim wSheet As Worksheet
Application.ScreenUpdating = False
For Each wSheet In Worksheets
Next
Dim Arr, Dy As Long
Dim Rng As Range, cell As Range
Dim Start As Boolean
Dim Prompt As String, RngStr As String
Prompt = "PLEASE CHECK YOUR DATA ENSURING ALL REQUIRED " & _
"CELLS ARE COMPLETE." & vbCrLf & "YOU WILL NOT BE ABLE " & _
"TO CLOSE OR SAVE THE DAILY REPORT UNTIL ALL THE REQUIRED CELLS ARE FILLED " & _
"OUT COMPLETELY. " & vbCrLf & vbCrLf & _
"THE CELLS LISTED BELOW CONTAIN NO DATA AND HAVE BEEN HIGHLIGHTED RED:" _
& vbCrLf & vbCrLf
Arr = Array("TUES", "WED", "THURS", "FRI", "SAT", "SUN", "MON")
For Dy = 0 To Weekday(Now, vbTuesday) - 1
With Worksheets(Format(Weekday(Date), "ddd"))
Start = True
Set Rng = TgtRange(.Name)
'highlights the blank cells
For Each cell In Rng
If cell.Value = vbNullString Then
cell.Interior.ColorIndex = 3 '** color red
If Start Then RngStr = RngStr & cell.Parent.Name & vbCrLf
Start = False
RngStr = RngStr & cell.Address(False, False) & " , "
Else
cell.Interior.ColorIndex = 36 '** Light Yellow
End If
Next
If RngStr <> "" Then RngStr = Left$(RngStr, Len(RngStr) - 0)
End With
Next
If RngStr <> "" Then
MsgBox Prompt & RngStr, vbCritical, "Incomplete Data"
Cancel = True
Else
'saves the changes before closing
ThisWorkbook.Save
Cancel = False
End If
For Each wSheet In Worksheets
Next
Application.ScreenUpdating = True
End Sub