BENSON
06-16-2008, 01:12 AM
The code below works fine ( It indictes wheather all required data has been entered ) ,I would like to alter the code so it will also check the other work sheets to see if all the data has been entered ,not just the current day.
thanks
Private Sub Workbook_Open()
Dim Arr
Dim Dy As String
Arr = Array("TUES", "WED", "THURS", "FRI", "SAT", "SUN", "MON")
Dy = Arr(Weekday(Date, vbTuesday) - 1 + LBound(Arr))
With Worksheets(Dy)
.Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0).Value = Dy & " " & _
Format(Date, "d mmmm yyyy")
Dim wSheet As Worksheet
Dim x As Long
Dim LastRow As Long
Application.ScreenUpdating = False
Sheets(1).Select
For Each wSheet In Worksheets
wSheet.Select
LastRow = Range("a" & Rows.Count).End(xlUp).Row
For x = LastRow To 1 Step -1
If Application.WorksheetFunction.CountIf(Range("a1:a" & x), Range("a" & x).Value) > 1 Then
Range("a" & x).EntireRow.Delete
End If
Next x
Next wSheet
Application.ScreenUpdating = True
End With
End Sub
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 = "" & _
"" & vbCrLf & " " & _
"" & _
" " & vbCrLf & vbCrLf & _
"THE CELLS LISTED BELOW AND HIGH LIGHTED YELLOW,HAVE STILL TO BE FILLED WITH DATA:" _
& vbCrLf & vbCrLf
Arr = Array("MON", "TUES", "WED", "THURS", "FRI", "SAT", "SUN")
For Dy = 0 To Weekday(Now, vbMonday) - 1
With Sheets(Arr(Dy))
Start = True
Set Rng = TgtRange(.Name)
'highlights the blank cells
For Each cell In Rng
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) - 0)
End With
Next
If RngStr <> "" Then
response = MsgBox(Prompt & RngStr & vbCrLf & "DO YOU WISH TO CLOSE THE HISTORY FILE AND COMPLETE LATER?", vbCritical + vbYesNo, "INCOMPLETE HISTORY TRANSFER")
Cancel = (response = vbNo)
Else
'saves the changes before closing
ThisWorkbook.Save
Cancel = False
End If
For Each wSheet In Worksheets
Next
Application.ScreenUpdating = True
End Sub
Function TgtRange(ShtName As String) As Range
With Sheets(ShtName)
Select Case ShtName
Case "TUES"
Set TgtRange = .Cells(.Rows.Count, "A").End(xlUp).Resize(, 25)
Case "WED"
Set TgtRange = .Cells(.Rows.Count, "A").End(xlUp).Resize(, 25)
Case "THURS"
Set TgtRange = .Cells(.Rows.Count, "A").End(xlUp).Resize(, 25)
Case "FRI"
Set TgtRange = .Cells(.Rows.Count, "A").End(xlUp).Resize(, 25)
Case "SAT"
Set TgtRange = .Cells(.Rows.Count, "A").End(xlUp).Resize(, 25)
Case "SUN"
Set TgtRange = .Cells(.Rows.Count, "A").End(xlUp).Resize(, 25)
Case "MON"
Set TgtRange = .Cells(.Rows.Count, "A").End(xlUp).Resize(, 25)
End Select
End With
End Function
thanks
Private Sub Workbook_Open()
Dim Arr
Dim Dy As String
Arr = Array("TUES", "WED", "THURS", "FRI", "SAT", "SUN", "MON")
Dy = Arr(Weekday(Date, vbTuesday) - 1 + LBound(Arr))
With Worksheets(Dy)
.Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0).Value = Dy & " " & _
Format(Date, "d mmmm yyyy")
Dim wSheet As Worksheet
Dim x As Long
Dim LastRow As Long
Application.ScreenUpdating = False
Sheets(1).Select
For Each wSheet In Worksheets
wSheet.Select
LastRow = Range("a" & Rows.Count).End(xlUp).Row
For x = LastRow To 1 Step -1
If Application.WorksheetFunction.CountIf(Range("a1:a" & x), Range("a" & x).Value) > 1 Then
Range("a" & x).EntireRow.Delete
End If
Next x
Next wSheet
Application.ScreenUpdating = True
End With
End Sub
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 = "" & _
"" & vbCrLf & " " & _
"" & _
" " & vbCrLf & vbCrLf & _
"THE CELLS LISTED BELOW AND HIGH LIGHTED YELLOW,HAVE STILL TO BE FILLED WITH DATA:" _
& vbCrLf & vbCrLf
Arr = Array("MON", "TUES", "WED", "THURS", "FRI", "SAT", "SUN")
For Dy = 0 To Weekday(Now, vbMonday) - 1
With Sheets(Arr(Dy))
Start = True
Set Rng = TgtRange(.Name)
'highlights the blank cells
For Each cell In Rng
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) - 0)
End With
Next
If RngStr <> "" Then
response = MsgBox(Prompt & RngStr & vbCrLf & "DO YOU WISH TO CLOSE THE HISTORY FILE AND COMPLETE LATER?", vbCritical + vbYesNo, "INCOMPLETE HISTORY TRANSFER")
Cancel = (response = vbNo)
Else
'saves the changes before closing
ThisWorkbook.Save
Cancel = False
End If
For Each wSheet In Worksheets
Next
Application.ScreenUpdating = True
End Sub
Function TgtRange(ShtName As String) As Range
With Sheets(ShtName)
Select Case ShtName
Case "TUES"
Set TgtRange = .Cells(.Rows.Count, "A").End(xlUp).Resize(, 25)
Case "WED"
Set TgtRange = .Cells(.Rows.Count, "A").End(xlUp).Resize(, 25)
Case "THURS"
Set TgtRange = .Cells(.Rows.Count, "A").End(xlUp).Resize(, 25)
Case "FRI"
Set TgtRange = .Cells(.Rows.Count, "A").End(xlUp).Resize(, 25)
Case "SAT"
Set TgtRange = .Cells(.Rows.Count, "A").End(xlUp).Resize(, 25)
Case "SUN"
Set TgtRange = .Cells(.Rows.Count, "A").End(xlUp).Resize(, 25)
Case "MON"
Set TgtRange = .Cells(.Rows.Count, "A").End(xlUp).Resize(, 25)
End Select
End With
End Function