BENSON
12-19-2007, 11:48 PM
I have a work book with seven sheets labeled MON TUES WED THURS SAT SUN MON.The code below we only work if it runs on a Wednesday the line of code which seems to be the problem is
With Worksheets(Format(Weekday(Date), "ddd"))
The whole code is below
Private Sub Workbook_Open()
With Worksheets(Format(Weekday(Date), "ddd"))
.Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0).Value = Date
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 = "PLEASE CHECK YOUR DATA ENSURING ALL REQUIRED " & _
"CELLS ARE COMPLETE." & vbCrLf & "YOU WILL NOT BE ABLE " & _
"TO CLOSE OR SAVE THE DAILY REPORT UNTIL ALL THE REQUIRED CELLS ARE FILLED " & _
"OUT COMPLETELY. " & vbCrLf & vbCrLf & _
"THE CELLS LISTED BELOW CONTAIN NO DATA AND HAVE BEEN HIGHLIGHTED RED:" _
& vbCrLf & vbCrLf
Arr = Array("TUES", "WED", "THURS", "FRI", "SAT", "SUN", "MON")
For Dy = 0 To Weekday(Now, vbTuesday) - 1
With Worksheets(Format(Weekday(Date), "ddd"))
Start = True
Set Rng = TgtRange(.Name)
'highlights the blank cells
For Each cell In Rng
If cell.Value = vbNullString Then
cell.Interior.ColorIndex = 3 '** color red
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
MsgBox Prompt & RngStr, vbCritical, "Incomplete Data"
Cancel = True
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(, 26)
Case "WED"
Set TgtRange = .Cells(.Rows.Count, "a").End(xlUp).Resize(, 26)
Case "THURS"
Set TgtRange = .Cells(.Rows.Count, "a").End(xlUp).Resize(, 26)
Case "FRI"
Set TgtRange = .Cells(.Rows.Count, "a").End(xlUp).Resize(, 26)
Case "SAT"
Set TgtRange = .Cells(.Rows.Count, "a").End(xlUp).Resize(, 26)
Case "SUN"
Set TgtRange = .Cells(.Rows.Count, "a").End(xlUp).Resize(, 26)
Case "MON"
Set TgtRange = .Cells(.Rows.Count, "a").End(xlUp).Resize(, 26)
End Select
End With
End Function
Thanks for any help
With Worksheets(Format(Weekday(Date), "ddd"))
The whole code is below
Private Sub Workbook_Open()
With Worksheets(Format(Weekday(Date), "ddd"))
.Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0).Value = Date
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 = "PLEASE CHECK YOUR DATA ENSURING ALL REQUIRED " & _
"CELLS ARE COMPLETE." & vbCrLf & "YOU WILL NOT BE ABLE " & _
"TO CLOSE OR SAVE THE DAILY REPORT UNTIL ALL THE REQUIRED CELLS ARE FILLED " & _
"OUT COMPLETELY. " & vbCrLf & vbCrLf & _
"THE CELLS LISTED BELOW CONTAIN NO DATA AND HAVE BEEN HIGHLIGHTED RED:" _
& vbCrLf & vbCrLf
Arr = Array("TUES", "WED", "THURS", "FRI", "SAT", "SUN", "MON")
For Dy = 0 To Weekday(Now, vbTuesday) - 1
With Worksheets(Format(Weekday(Date), "ddd"))
Start = True
Set Rng = TgtRange(.Name)
'highlights the blank cells
For Each cell In Rng
If cell.Value = vbNullString Then
cell.Interior.ColorIndex = 3 '** color red
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
MsgBox Prompt & RngStr, vbCritical, "Incomplete Data"
Cancel = True
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(, 26)
Case "WED"
Set TgtRange = .Cells(.Rows.Count, "a").End(xlUp).Resize(, 26)
Case "THURS"
Set TgtRange = .Cells(.Rows.Count, "a").End(xlUp).Resize(, 26)
Case "FRI"
Set TgtRange = .Cells(.Rows.Count, "a").End(xlUp).Resize(, 26)
Case "SAT"
Set TgtRange = .Cells(.Rows.Count, "a").End(xlUp).Resize(, 26)
Case "SUN"
Set TgtRange = .Cells(.Rows.Count, "a").End(xlUp).Resize(, 26)
Case "MON"
Set TgtRange = .Cells(.Rows.Count, "a").End(xlUp).Resize(, 26)
End Select
End With
End Function
Thanks for any help