PDA

View Full Version : Solved: Complete Data Entry Before Close



BENSON
12-18-2006, 12:25 AM
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



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

mdmackillop
12-18-2006, 01:16 AM
Hi Benson
Welcome to VBAX
You could use something like the following to loop through your sheets
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

Bob Phillips
12-18-2006, 02:21 AM
How about hiding all the later sheets on workbook open



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


and test for visible sheets in your code.

lucas
12-19-2006, 08:09 AM
Benson,
Has either of the above suggestions helped you with this?

BENSON
12-20-2006, 01:42 AM
I have tried hiding the work sheets but to no avail,if anyone has further suggestions I would appreciate the help.

THKS

moa
12-20-2006, 02:29 AM
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
12-20-2006, 03:07 AM
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



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

JimmyTheHand
12-20-2006, 03:15 AM
I put together your code and MD's, mixed with a little of my own ideas, and got this.
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

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
12-20-2006, 03:27 AM
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
12-20-2006, 10:08 AM
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
12-20-2006, 11:01 PM
THANK YOU ALL