Solved: Complele Daily Entries before Closing Worksheet

last week you helped me to convert a code to opperate on a daily basis dependng on the day of the week.I need to force people to complete specific entries prior to closing Could you help me insert a code to make the vba code below opperate on a daily basis.The workbook has only one sheet. I would like Rng1-Rng8 to be linked to a day of the week Rng1 being Tuesday thru to Rng8 Monday.If today was Wednesday Rng1-Rng3 would be active, the other Ranges would not be effected as the data is not required untill due date I would be glad of any Help

Thks

[VBA]
Private Sub Workbook_BeforeClose(Cancel As Boolean)




Dim Start As Boolean
Dim Rng1 As Range, Rng3 As Range, Rng4 As Range, Rng5 As Range, Rng6 As Range, Rng7 As Range, Rng8 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("DAILY STOCK").Range("d5:d200")
Set Rng3 = Sheets("DAILY STOCK").Range("f5:f200")
Set Rng4 = Sheets("DAILY STOCK").Range("h5:h200")
Set Rng5 = Sheets("DAILY STOCK").Range("j5:j200")
Set Rng6 = Sheets("DAILY STOCK").Range("l5:l200")
Set Rng7 = Sheets("DAILY STOCK").Range("n5:n200")
Set Rng8 = Sheets("DAILY STOCK").Range("p5:p200")
Set Rng9 = Sheets("DAILY STOCK").Range("v5:v200")

'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)
Start = True
If RngStr <> "" Then RngStr = RngStr & vbCrLf & vbCrLf
For Each Cell In Rng5
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 Rng6
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 Rng7
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 Rng8
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 Rng9
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
Set Rng5 = Nothing
Set Rng6 = Nothing
Set Rng7 = Nothing
Set Rng8 = Nothing


End Sub
[/VBA]

Hi Benson :hi:

This, again, should be done with a loop. However, it's a bit confusing why you don't use Rng2 as a range. Why Rng1, Rng3, Rng4, etc? I assumed it was not important how the ranges were called, so I took the liberty to create new names in my version of the code. It's the array Rng(8).

I don't know what should be done with Rng9, (in my version Rng(8),) because, if I got it right, it belongs to neither of the days, and you haven't explicitely expressed your will about it. So my code doesn't check it at all. But it would be simple enough to update, once I know the goal.

Also, I replaced Cell.Parent.Name with UCase(DayName(DayIndex - 1)). The former added the sheet's name before the list of empty cells of each range, which made sense when there were separate sheets for each day. But now the worksheet name is the same for all ranges. The latter, on the other hand, adds the day's name, which is different for each range.

Please comment.

[vba]Option Explicit

Private Sub Workbook_BeforeClose(Cancel As Boolean)
Dim Start As Boolean
Dim Rng(8) As Range
Dim ThisDay As Long, DayIndex As Long, DayName


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 Rng(1) = Sheets("DAILY STOCK").Range("d5:d200")
Set Rng(2) = Sheets("DAILY STOCK").Range("f5:f200")
Set Rng(3) = Sheets("DAILY STOCK").Range("h5:h200")
Set Rng(4) = Sheets("DAILY STOCK").Range("j5:j200")
Set Rng(5) = Sheets("DAILY STOCK").Range("l5:l200")
Set Rng(6) = Sheets("DAILY STOCK").Range("n5:n200")
Set Rng(7) = Sheets("DAILY STOCK").Range("p5:p200")
Set Rng(8) = Sheets("DAILY STOCK").Range("v5:v200")

ThisDay = Weekday(Date, vbTuesday)
DayName = Array("Tuesday", "Wednesday", "Thursday", "Friday", "Saturday", "Sunday", "Monday")

'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 DayIndex = 1 To ThisDay
For Each Cell In Rng(DayIndex)
If Cell.Value = vbNullString Then
Cell.Interior.ColorIndex = 6 '** color yellow
If Start Then RngStr = RngStr & UCase(DayName(DayIndex - 1)) & 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)
Next DayIndex

If RngStr <> "" Then
MsgBox Prompt & RngStr, vbCritical, "Incomplete Data"
Cancel = True
Else
'saves the changes before closing
ThisWorkbook.Save
Cancel = False
End If
End Sub[/vba]

Many Thks for the code Jimmy,Range 9 (NOW RNG 8) is a closing stock column and should be completed on the same day as RNG 7 .So in effect the user must be forced to enter data into RNG7 & RNG8 on the MONDAY.

I am really thankful for all the help I receive from you guys .

Well, then. Most of the code is the same, only one line new, and one modified.

[vba] ThisDay = Weekday(Date, vbTuesday) '<-- this line is unchanged
if ThisDay = 7 Then ThisDay = 8 '<-- this is a new line, forcing the loop to process Rng(8) when it's 7th day of week (i.e. on Monday).
DayName = Array("Tuesday", "Wednesday", "Thursday", "Friday", "Saturday", "Sunday", "Monday", "Closing Stock")) '<-- this line is modified. Added name for "8th day" [/vba] I haven't tested it, but it should work.

:)
Jimmy