Solved: Complete Data Entry Before Close

[BENSON]

Could the code seen below,be altered to only operate on a individual worksheets of a certain day of week is gone .IE

The workbook contains seven sheets named MON-SUN and the data on each sheet is the same but has to be entered on a specific day .If to day was Wednesday code should only work for sheets MON_WED and ignore sheets Thur -SUN as the data is notrequired for those sheets yet.

Many thanks if you can help



[vba]Option Explicit

Private Sub Workbook_BeforeClose(Cancel As Boolean)
Dim Start As Boolean
Dim Rng1 As Range, Rng3 As Range, Rng4 As Range

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 Rng1 = Sheets("Group Profile").Range("B5:B14,F1,F5:F7,B20:B22,B26:B31,B38:B45,B49:B52")
Set Rng3 = Sheets("Eligibility Guidelines").Range("F1,E5,E6,E9,E10,B7:B17,B21:B36")
Set Rng4 = Sheets("COBRA").Range("J2,H4,H5,J15,B4,B5,B9,B10:B13,B17:B20,B25:B28,E17: E20")
'message is returned if there are blank cells
Prompt = "Please check your data ensuring all required " & _
"cells are complete." & vbCrLf & "you will not be able " & _
"to close or save the workbook until the form has been filled " & _
"out completely. " & vbCrLf & vbCrLf & _
"The following cells are incomplete and have been highlighted yellow:" _
& vbCrLf & vbCrLf
Start = True
'highlights the blank cells
For Each Cell In Rng1
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) - 2)
Start = True
If RngStr <> "" Then RngStr = RngStr & vbCrLf & vbCrLf
For Each Cell In Rng3
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) - 2)
Start = True
If RngStr <> "" Then RngStr = RngStr & vbCrLf & vbCrLf
For Each Cell In Rng4
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) - 2)
If RngStr <> "" Then
MsgBox Prompt & RngStr, vbCritical, "Incomplete Data"
Cancel = True
Else
'saves the changes before closing
ThisWorkbook.Save
Cancel = False
End If

Set Rng1 = Nothing
Set Rng3 = Nothing
Set Rng4 = Nothing

End Sub [/vba]

[mdmackillop]

Hi Benson
Welcome to VBAX
You could use something like the following to loop through your sheets
[vba]Option Explicit

Sub Days()
Dim Arr, Dy As Long
Dim i As Long

Arr = Array("Monday", "Tuesday", "Wednesday", "Thursday", "Friday", "Saturday", "Sunday")
Dy = Weekday(Now())
If Dy = 1 Then Dy = Dy + 7
For i = 0 To Dy - 2
With Sheets(Arr(i))
MsgBox Sheets(Arr(i)).Name
End With
Next
End Sub

[/vba]

[Bob Phillips]

How about hiding all the later sheets on workbook open

[vba]

Private Sub Workbook_Open()
Dim aryDays
Dim i As Long, j As Long

aryDays = Array("Mon", "Tue", "Wed", "Thu", "Fri", "Sat", "Sun")
i = Application.Match(Format(Date, "ddd"), aryDays, 0)
For j = i To UBound(aryDays)
Worksheets(aryDays(j)).Visible = xlSheetHidden
Next j
End Sub
[/vba]

and test for visible sheets in your code.

[lucas]

Benson,
Has either of the above suggestions helped you with this?

[BENSON]

I have tried hiding the work sheets but to no avail,if anyone has further suggestions I would appreciate the help.

THKS

[moa]

Post your code as it is now after trying the suggestion(s). md's code seems to be what you need, based on your original post.

[BENSON]

HI Glen I have posted altered code below I am not 100% sure as to where I should insert md's code ? I appreciate the help

Thks


[VBA]
Option Explicit
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Dim Start As Boolean
Dim Rng1 As Range, Rng3 As Range, Rng4 As Range, Rng5 As Range, Rng6 As Range, Rng7 As Range, Rng8 As Range



Dim Prompt As String, RngStr As String
Dim Cell As Range

Set Rng1 = Sheets("MON").Range("a4")
Set Rng3 = Sheets("TUES").Range("a4")
Set Rng4 = Sheets("WED").Range("a4")

Set Rng5 = Sheets("THURS").Range("a4")
Set Rng6 = Sheets("FRI").Range("a4")
Set Rng7 = Sheets("SAT").Range("a4")
Set Rng8 = Sheets("SUN").Range("a4")
'message is returned if there are blank cells
Prompt = "Please check your data ensuring all required " & _
"cells are complete." & vbCrLf & "you will not be able " & _
"to close or save the workbook until the form has been filled " & _
"out completely. " & vbCrLf & vbCrLf & _
"The following cells are incomplete and have been highlighted red:" _
& vbCrLf & vbCrLf
Start = True
'highlights the blank cells
For Each Cell In Rng1
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) - 2)
Start = True
If RngStr <> "" Then RngStr = RngStr & vbCrLf & vbCrLf
For Each Cell In Rng3
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) - 2)
Start = True
If RngStr <> "" Then RngStr = RngStr & vbCrLf & vbCrLf
For Each Cell In Rng4
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) - 2)
Start = True
If RngStr <> "" Then RngStr = RngStr & vbCrLf & vbCrLf
For Each Cell In Rng5
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) - 2)
Start = True
If RngStr <> "" Then RngStr = RngStr & vbCrLf & vbCrLf
For Each Cell In Rng6
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) - 2)
Start = True
If RngStr <> "" Then RngStr = RngStr & vbCrLf & vbCrLf
For Each Cell In Rng7
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) - 2)
Start = True
If RngStr <> "" Then RngStr = RngStr & vbCrLf & vbCrLf
For Each Cell In Rng8
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) - 2)
If RngStr <> "" Then
MsgBox Prompt & RngStr, vbCritical, "Incomplete Data"
Cancel = True
Else
'saves the changes before closing
ThisWorkbook.Save
Cancel = False
End If

Set Rng1 = Nothing
Set Rng3 = Nothing
Set Rng4 = Nothing
Set Rng5 = Nothing
Set Rng6 = Nothing
Set Rng7 = Nothing
Set Rng8 = Nothing

End Sub
[/VBA]

[JimmyTheHand]

I put together your code and MD's, mixed with a little of my own ideas, and got this.
[vba]Private Sub Workbook_BeforeClose(Cancel As Boolean)
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 workbook until the form has been filled " & _
"out completely. " & vbCrLf & vbCrLf & _
"The following cells are incomplete and have been highlighted yellow:" _
& 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) - 2)
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
End Sub


Function TgtRange(ShtName As String) As Range
Select Case ShtName
Case "MON"
Set TgtRange = Sheets(ShtName).Range("A4")
Case "TUES"
Set TgtRange = Sheets(ShtName).Range("A4")
Case "WED"
Set TgtRange = Sheets(ShtName).Range("A4")
Case "THURS"
Set TgtRange = Sheets(ShtName).Range("A4")
Case "FRI"
Set TgtRange = Sheets(ShtName).Range("A4")
Case "SAT"
Set TgtRange = Sheets(ShtName).Range("A4")
Case "SUN"
Set TgtRange = Sheets(ShtName).Range("A4")
End Select
End Function[/vba]

I'm not sure what ranges do you want to check on each day's sheet, or even if they are the same on each sheet. So I made a function (called TgtRange) where you can define it for each day separately, or anyway you see fit. I predefined Range("A4") for each, but of course you will change it.

Didn't try the code because I have no sample data.

[BENSON]

Many thanks to all the code works just fine .I cant say how pleased I am that I found your Forum.Onceagain many thanks

[lucas]

Glad it worked out Benson. If it's resolved would you please mark your thread solved using thread tools at the top of the page. Good contributions from all. Nice work Jimmy

[BENSON]

THANK YOU ALL