BENSON
12-18-2006, 12:25 AM
Could the code seen below,be altered to only operate on a individual worksheets of a certain day of week is gone .IE
The workbook contains seven sheets named MON-SUN and the data on each sheet is the same but has to be entered on a specific day .If to day was Wednesday code should only work for sheets MON_WED and ignore sheets Thur -SUN as the data is notrequired for those sheets yet.
Many thanks if you can help
Option Explicit
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Dim Start As Boolean
Dim Rng1 As Range, Rng3 As Range, Rng4 As Range
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("Group Profile").Range("B5:B14,F1,F5:F7,B20:B22,B26:B31,B38:B45,B49:B52")
Set Rng3 = Sheets("Eligibility Guidelines").Range("F1,E5,E6,E9,E10,B7:B17,B21:B36")
Set Rng4 = Sheets("COBRA").Range("J2,H4,H5,J15,B4,B5,B9,B10:B13,B17:B20,B25:B28,E17: E20")
'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
ThisWorkbook.Save
Cancel = False
End If
Set Rng1 = Nothing
Set Rng3 = Nothing
Set Rng4 = Nothing
End Sub
The workbook contains seven sheets named MON-SUN and the data on each sheet is the same but has to be entered on a specific day .If to day was Wednesday code should only work for sheets MON_WED and ignore sheets Thur -SUN as the data is notrequired for those sheets yet.
Many thanks if you can help
Option Explicit
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Dim Start As Boolean
Dim Rng1 As Range, Rng3 As Range, Rng4 As Range
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("Group Profile").Range("B5:B14,F1,F5:F7,B20:B22,B26:B31,B38:B45,B49:B52")
Set Rng3 = Sheets("Eligibility Guidelines").Range("F1,E5,E6,E9,E10,B7:B17,B21:B36")
Set Rng4 = Sheets("COBRA").Range("J2,H4,H5,J15,B4,B5,B9,B10:B13,B17:B20,B25:B28,E17: E20")
'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
ThisWorkbook.Save
Cancel = False
End If
Set Rng1 = Nothing
Set Rng3 = Nothing
Set Rng4 = Nothing
End Sub