PDA

View Full Version : Solved: MsgBox if birthdate is <1 year ago?



Gingertrees
08-06-2009, 12:31 PM
One of my users enlightened me on an error I had not forseen: if the user inputs an adult client's birthdate with THIS YEAR instead of the actual birthdate. I.e., 1/12/1940 becomes 1/12/2009. Suddenly someone who should be Medicare-eligible is WIC-eligible! (:rotlaugh: ...American/social work joke)

Anyway, we do have pediatric clients, so I don't want to BLOCK dates <1. I just want a pop-up to catch the careless user.

Here's what I'd like:
If (birthday) < TODAY()-365,
Then Msgbox "Is client an infant? If no, correct birth year." [Yes] [No]

I hope this is easier than my last question...

mdmackillop
08-06-2009, 01:36 PM
Why not use conditional formatting to turn the cell red. Much simpler
=NOW() -D1<367

mikerickson
08-06-2009, 06:28 PM
Alternatly, Data Validation could cause a message to appear.

Gingertrees
08-06-2009, 07:13 PM
Unfortunately I have noticed that, despite my warnings, my users don't notice a.k.a. CARE when the conditional formatting is triggered and the cell turns colors.

Data val would give the message box, but wouldn't that prevent pediatric cases from being entered? I just want the user to have to look twice.

mikerickson
08-06-2009, 10:26 PM
If a validation Error Alert is set to Style: Information, the user can enter invalid data.

mdmackillop
08-07-2009, 01:58 AM
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Test As Long
Dim ChkDate As Long
ChkDate = Date - DateValue("31/12/" & Year(Date) - 1)
If Target.Column = 4 Then
If Date - Target < ChkDate Then
Test = MsgBox("Is patient less than one year old?", vbYesNo + vbDefaultButton2 + vbQuestion)
If Test = vbYes Then
Target.Offset(, 1).Select
Else
Target = InputBox("Please enter the date in full", "Full Date", "dd/mm/yyyy")
Target.Offset(, 1).Select
End If
End If
End If
End Sub

Gingertrees
08-07-2009, 09:47 AM
Great! That should fix it.
One tiny problem: the 2nd message box circumvents my DataVal date-checker. How do I prevent entries like 90/11/6000 or 3/7/1704?

Bob Phillips
08-07-2009, 10:04 AM
You might need to add sosme more specific date checks



Private Sub Worksheet_Change(ByVal Target As Range)
Dim Test As Long
Dim ChkDate As Long
Dim tmp

On Error GoTo ws_exit
Application.EnableEvents = False
ChkDate = Date - DateValue("31/12/" & Year(Date) - 1)
If Target.Column = 4 Then

If Date - Target < ChkDate Then

Test = MsgBox("Is patient less than one year old?", vbYesNo + vbDefaultButton2 + vbQuestion)
If Test = vbYes Then

Target.Offset(, 1).Select
Else

tmp = InputBox("Please enter the date in full", "Full Date", "dd/mm/yyyy")
If Not IsDate(tmp) Then

MsgBox "Invalid date"
Else

Target.Value = CDate(tmp)
Target.Offset(, 1).Select
End If
End If
End If
End If

ws_exit:
Application.EnableEvents = True
End Sub

Gingertrees
08-07-2009, 11:13 AM
Mostly solved the problem...and I ALMOST know how to fix it. Except I keep ending up with an "End if with no Block if" error. Never encountered that one before.

Scenario I want:
User enters 8/1/2009. Didn't mean to, meant to enter 8/1/89. User types 88/11/999 in the message box. Receives "Invalid date" error. When user clicks "OK" (I'd prefer "Try again"), he's presented with the message box. I want this to loop forever or until he gets the date right, whichever happens first.

Here's what I have added on to the others' code:

Private Sub Worksheet_Change(ByVal Target As Range)
Dim Test As Long
Dim ChkDate As Long
Dim Test2 As Long
Dim tmp

On Error GoTo ws_exit
Application.EnableEvents = False
ChkDate = Date - DateValue("12/31/" & Year(Date) - 1)
If Target.Column = 4 Then

If Date - Target < ChkDate Then

Test = MsgBox("****Date Check**** Is client less than one year old?", vbYesNo + vbDefaultButton2 + vbQuestion)
If Test = vbYes Then

Target.Offset(, 1).Select
Else

tmp = InputBox("Please enter the date in full", "Full Date", "mm/dd/yyyy")
If Not IsDate(tmp) Then

Test2 = MsgBox("Invalid date", vbCritical, vbDefaultButton2)
If Test2 = vbOK Then

'//////-->How can I get it to look back to tmp?<--/////////

Else

Target.Value = CDate(tmp)
Target.Offset(, 1).Select
End If
End If
End If
End If

ws_exit:
Application.EnableEvents = True
End Sub

Bob Phillips
08-07-2009, 12:06 PM
I may be missing this, but try



Private Sub Worksheet_Change(ByVal Target As Range)
Dim Test As Long
Dim ChkDate As Long
Dim Test2 As Long
Dim tmp

On Error GoTo ws_exit
Application.EnableEvents = False
ChkDate = DateValue("12/31/" & Year(Date) - 1)
If Target.Column = 4 Then

If Target < ChkDate Then

Test = MsgBox("****Date Check**** Is client less than one year old?", vbYesNo + vbDefaultButton2 + vbQuestion)
If Test = vbYes Then

Target.Offset(, 1).Select
Else

Do

tmp = InputBox("Please enter the date in full", "Full Date", "mm/dd/yyyy")
If Not IsDate(tmp) Then Test2 = MsgBox("Invalid date", vbOKCancel, vbDefaultButton2)
Loop Until IsDate(tmp) Or Test2 = vbCancel

If Not Test2 = vbCancel Then

Target.Value = CDate(tmp)
Target.Offset(, 1).Select
End If
End If
End If
End If

ws_exit:
Application.EnableEvents = True
End Sub

mdmackillop
08-07-2009, 04:42 PM
Hi Gingertrees,m
Use a Code Indenter (see my signature) . Your code in post #9 clearly shows an error as Sub and End Sub are not aligned.

Gingertrees
08-17-2009, 08:27 AM
OK, xld, I tried your code. As noted by mdmackillop, my indentation was off. (Thanks for catching that!)

But now the code is firing randomly - I inputted a date from 2007 and it triggered the message box. I inputed a date from 1967 and it triggered the message box. I tried 3/1/2009 and it did NOT trigger. What's going on?

Bob Phillips
08-17-2009, 11:19 AM
Because there is a check in the code that the date is less than 31st Dec last year.

Gingertrees
08-17-2009, 11:31 AM
I don't understand...

mdmackillop
08-18-2009, 05:32 AM
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Test As Long
Dim ChkDate As Long
Dim Age As Long
Dim Dte
If Target.Column <> 4 Then Exit Sub
If Target.Cells.Count > 1 Then Exit Sub
If Not IsDate(Target) Then
Dte = InputBox("Invalid date entered.", "Full Date", "dd/mm/yyyy")
If Dte = "" Or Not IsDate(Dte) Then
Application.EnableEvents = False
Target.ClearContents
Application.EnableEvents = True
Exit Sub
Else
Target = Dte
End If
End If
ChkDate = Date - DateValue("31/12/" & Year(Date) - 1)
Select Case Date - Target
Case Is < 0
Test = MsgBox("This date is in the future!", vbExclamation)
Target = InputBox("Please enter the date in full", "Full Date", "dd/mm/yyyy")
Case Is < ChkDate
Test = MsgBox("Is patient less than one year old?", vbYesNo + vbDefaultButton2 + vbQuestion)
If Test = vbYes Then
Target.Offset(, 1).Select
Else
Target = InputBox("Please enter the date in full", "Full Date", "dd/mm/yyyy")
Target.Offset(, 1).Select
End If
Case Is > 32000 'Over 87 years
Age = (Date - Target) / 365.25
Test = MsgBox("Is patient approx. " & Age & " years old?", vbYesNo + vbDefaultButton2 + vbQuestion)
If Test = vbYes Then
Target.Offset(, 1).Select
Else
Target = InputBox("Please enter the correct date", "Full Date", "dd/mm/yyyy")
Target.Offset(, 1).Select
End If
End Select
End Sub

Gingertrees
08-18-2009, 06:27 AM
Great! I like the age approximation too - that's a nice touch. Thanks a lot!!

mdmackillop
08-18-2009, 06:48 AM
That was really to test for "old" but valid dates. You could add another Case to check "normal" ages.

Gingertrees
08-18-2009, 08:08 AM
I noticed that...I changed it to >365 so it verifies every date that doesn't trigger the safeguards. If the peasants revolt I'll leave it as you wrote it to check for very mature clients.

Gingertrees
08-19-2009, 12:14 PM
I do not understand. In my abbreviated spreadsheet this worked beautifully. I pasted the same exact code into my ACTUAL database and it does nothing.
I am so frustrated! How can I learn this language when it doesn't even do the things it's supposed to do?!
Here's the code, in the standard module (not ThisWorkbook):

Option Explicit
Private Sub BirthdateCheck(ByVal Target As Range)
Dim Test As Long
Dim ChkDate As Long
Dim Age As Long
Dim Dte
If Target.Column <> 4 Then Exit Sub
If Target.Cells.Count > 1 Then Exit Sub
If Not IsDate(Target) Then
Dte = InputBox("Invalid date entered.", "Full Date", "mm/dd/yyyy")
If Dte = "" Or Not IsDate(Dte) Then
Application.EnableEvents = False
Target.ClearContents
Application.EnableEvents = True
Exit Sub
Else
Target = Dte
End If
End If
ChkDate = Date - DateValue("12/31/" & Year(Date) - 1)
Select Case Date - Target
Case Is < 0
Test = MsgBox("This date is in the future!", vbExclamation)
Target = InputBox("Please enter the date in full", "Full Date", "mm/dd/yyyy")
Case Is < ChkDate
Test = MsgBox("Is client less than one year old?", vbYesNo + vbDefaultButton2 + vbQuestion)
If Test = vbYes Then
Target.Offset(, 1).Select
Else
Target = InputBox("Please enter the date in full", "Full Date", "mm/dd/yyyy")
Target.Offset(, 1).Select
End If
Case Is > 365
'final check if date was entered correctly
Age = (Date - Target) / 365.25
Test = MsgBox("Is client approx. " & Age & " years old?", vbYesNo + vbDefaultButton2 + vbQuestion)
If Test = vbYes Then
Target.Offset(, 1).Select
Else
Target = InputBox("Please enter the correct date", "Full Date", "mm/dd/yyyy")
Target.Offset(, 1).Select
End If
End Select
End Sub



help? please?
I'm in over my head on this darn project...

Bob Phillips
08-19-2009, 12:34 PM
Post the workbook, it will help solving it.

Gingertrees
08-19-2009, 01:01 PM
unfortunately this workbook, in it's complete form, is huge and riddled with information that my company probably would not like broadcast worldwide, so I have yet again trimmed its size. None of the sheets that were removed had relevant data or code, so they shouldn't affect the outcome...

please let me know how to make this work again, like it did yesterday with GingerUpdate....

Aussiebear
08-20-2009, 12:54 AM
please let me know how to make this work again, like it did yesterday with GingerUpdate....

Please report to the firing squad, with your blindfold.......

Blah blah blah always make a copy blah blah blah before doing anything drastic blah blah blah.....

Say here's an idea..... when you downloaded GingerUpdate was it stored anywhere on your system?

Gingertrees
08-20-2009, 05:21 AM
Of course. I have made clones of my untouched copy, pasted in the code above, but to no avail.

Did I just imagine that it worked before? Or was I simply in some parallel universe where computers do not hate me?

Gingertrees
09-13-2009, 03:09 PM
Hello everyone,
Here (at last!) is the workbook that somehow kills mdmackillop's otherwise-perfect solution from page 1 of this thread:
http://www.vbaexpress.com/forum/showthread.php?t=27942&page=1

Now the code does not do what it was designed to do. I can enter 1/1/1964 or 2/2/2009 and it will react the same: do nothing (no popups, no error, etc).

What it SHOULD be doing: verifying all DOBs (column #4) with "Is client approximately X years old?", if no, erroring if user enters invalid date, verifing age again "is client approx. Y years old?", looping ad infinitum if necessary. please help?

(Sorry I had to zip the file - it's rather large)

GTO
09-16-2009, 11:39 PM
Greetings,

In your attached wb (at #24), you have the private sub 'BirthdateCheck(ByVal Target As Range)' in the worksheet "Cases" module.

But the procedure is never called from 'Worksheet_Change'.

You could call the procedure like:

Private Sub Worksheet_Change(ByVal Target As Range)
Call BirthdateCheck(Target)
End Sub

...but I would think you would just want to put the code back into Worksheet_Change like Malcom's and Bob's.

Hope that helps,

Mark

Gingertrees
09-17-2009, 10:34 AM
:cloud9: Thank you!!!!! Well my face is red, but the important part is the darn thing WORKS now.

VBA newbie lesson of the day: the title of the routine DOES matter
~Ariel