BENSON
01-04-2007, 11:55 PM
The code below works great on my spread sheet ,it is designed to force users to enter data before closing or saving on certain days of the week, seven colums Tue- Mon .Could further code be added to stop users from entering data into a day colum that has not yet arrived.Ie if today is Fri do not allow any data imput in collums Sat- Mon, but allow data entry into Tue - Fri. This is to stop users from entering say Zeros in other cells to open and close worksheet without my error message showing
Thks
Option Explicit
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Application.ScreenUpdating = False
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:d240")
Set Rng(2) = Sheets("DAILY STOCK").Range("f5:f240")
Set Rng(3) = Sheets("DAILY STOCK").Range("h5:h240")
Set Rng(4) = Sheets("DAILY STOCK").Range("j5:j240")
Set Rng(5) = Sheets("DAILY STOCK").Range("l5:l240")
Set Rng(6) = Sheets("DAILY STOCK").Range("n5:n240")
Set Rng(7) = Sheets("DAILY STOCK").Range("p5:p240")
Set Rng(8) = Sheets("DAILY STOCK").Range("v5:v240")
ThisDay = Weekday(Date, vbTuesday)
If ThisDay = 7 Then ThisDay = 8
DayName = Array("Tuesday", "Wednesday", "Thursday", "Friday", "Saturday", "Sunday", "Monday", "Stock_Close")
'message is returned if there are blank cells
Prompt = "PLEASE COMPLETE TODAYS ENTRIES. " & _
"IF ANY CELLS ARE INCOMPLETE" & vbCrLf & "YOU WILL NOT BE ABLE " & _
"TO CLOSE OR SAVE THE WORBOOK " & _
" IF YOU DID NOT RECEIVE A PARTICULAR STOCK ITEM TODAY ENTER ZERO. " & 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 & Cells(Cell.Row, 1).Value & ", "
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
Application.ScreenUpdating = True
End Sub
Thks
Option Explicit
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Application.ScreenUpdating = False
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:d240")
Set Rng(2) = Sheets("DAILY STOCK").Range("f5:f240")
Set Rng(3) = Sheets("DAILY STOCK").Range("h5:h240")
Set Rng(4) = Sheets("DAILY STOCK").Range("j5:j240")
Set Rng(5) = Sheets("DAILY STOCK").Range("l5:l240")
Set Rng(6) = Sheets("DAILY STOCK").Range("n5:n240")
Set Rng(7) = Sheets("DAILY STOCK").Range("p5:p240")
Set Rng(8) = Sheets("DAILY STOCK").Range("v5:v240")
ThisDay = Weekday(Date, vbTuesday)
If ThisDay = 7 Then ThisDay = 8
DayName = Array("Tuesday", "Wednesday", "Thursday", "Friday", "Saturday", "Sunday", "Monday", "Stock_Close")
'message is returned if there are blank cells
Prompt = "PLEASE COMPLETE TODAYS ENTRIES. " & _
"IF ANY CELLS ARE INCOMPLETE" & vbCrLf & "YOU WILL NOT BE ABLE " & _
"TO CLOSE OR SAVE THE WORBOOK " & _
" IF YOU DID NOT RECEIVE A PARTICULAR STOCK ITEM TODAY ENTER ZERO. " & 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 & Cells(Cell.Row, 1).Value & ", "
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
Application.ScreenUpdating = True
End Sub