BENSON
12-31-2006, 12:08 AM
The following code works very well thanks to the help I received form this forum.I was wondering if rarther than returning the Ref num to a cell, that has not been completed, it could return the cells name.
For example if cell A5 has not been filled in, return not the the Ref A5 but the cells defined name ie: Bread Rolls
Many 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 " & vbCrLf & _
"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 & 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
Application.ScreenUpdating = True
End Sub
Edit by Lucas: Line breaks added for easier reading by those with small monitors.
For example if cell A5 has not been filled in, return not the the Ref A5 but the cells defined name ie: Bread Rolls
Many 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 " & vbCrLf & _
"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 & 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
Application.ScreenUpdating = True
End Sub
Edit by Lucas: Line breaks added for easier reading by those with small monitors.