BENSON
12-14-2007, 05:31 AM
The code below forces a user to enter data into specific cells before being able to close the workbook.This was fine ,but I now need to make the target range (B155:Z155) on all the work sheets variable,depending on the row that to days date gets posted into
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
If wSheet.ProtectContents = True Then
wSheet.Unprotect Password:="jimmi"
End If
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 = 36 '** Light Yellow
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
If wSheet.ProtectContents = False Then
wSheet.Protect Password:="jimmi"
End If
Next
Application.ScreenUpdating = True
End Sub
Function TgtRange(ShtName As String) As Range
Select Case ShtName
Case "TUES"
Set TgtRange = Sheets(ShtName).Range("b155:Z155")
Case "WED"
Set TgtRange = Sheets(ShtName).Range("b155:Z155")
Case "THURS"
Set TgtRange = Sheets(ShtName).Range("b155:Z155")
Case "FRI"
Set TgtRange = Sheets(ShtName).Range("b155:Z155")
Case "SAT"
Set TgtRange = Sheets(ShtName).Range("b155:Z155")
Case "SUN"
Set TgtRange = Sheets(ShtName).Range("b155:Z155")
Case "MON"
Set TgtRange = Sheets(ShtName).Range("b155:Z155")
End Select
End Function
Thanks for any help
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
If wSheet.ProtectContents = True Then
wSheet.Unprotect Password:="jimmi"
End If
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 = 36 '** Light Yellow
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
If wSheet.ProtectContents = False Then
wSheet.Protect Password:="jimmi"
End If
Next
Application.ScreenUpdating = True
End Sub
Function TgtRange(ShtName As String) As Range
Select Case ShtName
Case "TUES"
Set TgtRange = Sheets(ShtName).Range("b155:Z155")
Case "WED"
Set TgtRange = Sheets(ShtName).Range("b155:Z155")
Case "THURS"
Set TgtRange = Sheets(ShtName).Range("b155:Z155")
Case "FRI"
Set TgtRange = Sheets(ShtName).Range("b155:Z155")
Case "SAT"
Set TgtRange = Sheets(ShtName).Range("b155:Z155")
Case "SUN"
Set TgtRange = Sheets(ShtName).Range("b155:Z155")
Case "MON"
Set TgtRange = Sheets(ShtName).Range("b155:Z155")
End Select
End Function
Thanks for any help