PDA

View Full Version : Solved: Force user to enter data be for close



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

Bob Phillips
12-14-2007, 06:10 AM
How will you know?

BENSON
12-14-2007, 06:44 AM
Sorry if I did not explain clearly. On opening the spread sheet ,the date is pasted into the next vacant row in collum "A" in the releveant worksheet in the example code above this happen to be row (A155) on the spread sheet labled "FRI" if data has not been entered by a user into adjacent cells( B155:Z155 ) they are highlighted RED and the cells that are blank are listed in a msg box.I need the range which will always be ( B:Z) to be variable as if the worksheet is opened next Friday the date would apear in row "A156"

Thanks

Bob Phillips
12-14-2007, 06:48 AM
Okay, so you mean the last row always.

Here is an example of wht you need



With Sheets(ShtName)
Set TgtRange = .Cells(.Rows.Count, "B").End(xlUp).Resize(, 25)
End With


BTW< what is the point of the Case statement, it seems to do the same regardless of the Case?

BENSON
12-14-2007, 07:12 AM
yes it will always be the last row in any of the spread sheets.I tried your suggestion and got error Msg "Compile Argument Not Optioinal"

Bob Phillips
12-14-2007, 07:33 AM
That is odd, I don't.

Where did you put it, show the code as now, maybe post the workbook.

BENSON
12-14-2007, 09:59 PM
please check my revised code below , must have inserted suggested code in the wrong places. I really am gratefull for the the 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



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

Next
Application.ScreenUpdating = True
End Sub


Function TgtRange(ShtName As String) As Range
Select Case ShtName

Case "TUES"
Set TgtRange = .Cells(.Rows.Count, "B").End(xlUp).Resize(, 25)
Case "WED"
Set TgtRange = .Cells(.Rows.Count, "B").End(xlUp).Resize(, 25)
Case "THURS"
Set TgtRange = .Cells(.Rows.Count, "B").End(xlUp).Resize(, 25)
Case "FRI"
Set TgtRange = .Cells(.Rows.Count, "B").End(xlUp).Resize(, 25)
Case "SAT"
Set TgtRange = .Cells(.Rows.Count, "B").End(xlUp).Resize(, 25)
Case "SUN"
Set TgtRange = .Cells(.Rows.Count, "B").End(xlUp).Resize(, 25)
Case "MON"
Set TgtRange = .Cells(.Rows.Count, "B").End(xlUp).Resize(, 25)
End Select
End Function

Bob Phillips
12-15-2007, 03:00 AM
This bit



Function TgtRange(ShtName As String) As Range
Select Case ShtName

Case "TUES"
Set TgtRange = .Cells(.Rows.Count, "B").End(xlUp).Resize(, 25)
Case "WED"
Set TgtRange = .Cells(.Rows.Count, "B").End(xlUp).Resize(, 25)
Case "THURS"
Set TgtRange = .Cells(.Rows.Count, "B").End(xlUp).Resize(, 25)
Case "FRI"
Set TgtRange = .Cells(.Rows.Count, "B").End(xlUp).Resize(, 25)
Case "SAT"
Set TgtRange = .Cells(.Rows.Count, "B").End(xlUp).Resize(, 25)
Case "SUN"
Set TgtRange = .Cells(.Rows.Count, "B").End(xlUp).Resize(, 25)
Case "MON"
Set TgtRange = .Cells(.Rows.Count, "B").End(xlUp).Resize(, 25)
End Select
End Function


should be qualified by the sheet



Function TgtRange(ShtName As String) As Range
With Sheets(ShtName)
Select Case ShtName

Case "TUES"
Set TgtRange = .Cells(.Rows.Count, "B").End(xlUp).Resize(, 25)
Case "WED"
Set TgtRange = .Cells(.Rows.Count, "B").End(xlUp).Resize(, 25)
Case "THURS"
Set TgtRange = .Cells(.Rows.Count, "B").End(xlUp).Resize(, 25)
Case "FRI"
Set TgtRange = .Cells(.Rows.Count, "B").End(xlUp).Resize(, 25)
Case "SAT"
Set TgtRange = .Cells(.Rows.Count, "B").End(xlUp).Resize(, 25)
Case "SUN"
Set TgtRange = .Cells(.Rows.Count, "B").End(xlUp).Resize(, 25)
Case "MON"
Set TgtRange = .Cells(.Rows.Count, "B").End(xlUp).Resize(, 25)
End Select
End With
End Function


But I still don't see the point of the Case?

BENSON
12-15-2007, 09:31 AM
It works perfect now thank you so much for you help .One query? If a cell or cells is not filled in ,the message box appears and informs the user which cells are not completed this is correct but the information repeats it self ie: if cell "B156 " is blank message box returns

SAT
B156,SAT
B156,SAT
B156,SAT

I can live with it but maybe you could shed some light as to why it would do it

Thanks once again this forum is great