Solved: MsgBox if birthdate is <1 year ago?

[Gingertrees]

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! ( ...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]

Why not use conditional formatting to turn the cell red. Much simpler
=NOW() -D1<367

[mikerickson]

Alternatly, Data Validation could cause a message to appear.

[Gingertrees]

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]

If a validation Error Alert is set to Style: Information, the user can enter invalid data.

[mdmackillop]

[VBA]
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

[/VBA]

[Gingertrees]

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]

You might need to add sosme more specific date checks

[vba]

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
[/vba]

[Gingertrees]

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:
[VBA]
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
[/VBA]

[Bob Phillips]

I may be missing this, but try

[vba]

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
[/vba]

[mdmackillop]

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]

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]

Because there is a check in the code that the date is less than 31st Dec last year.

[Gingertrees]

I don't understand...

[mdmackillop]

[VBA]
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
[/VBA]

[Gingertrees]

Great! I like the age approximation too - that's a nice touch. Thanks a lot!!

[mdmackillop]

That was really to test for "old" but valid dates. You could add another Case to check "normal" ages.

[Gingertrees]

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]

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):
[vba]
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

[/vba]

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

[Bob Phillips]

Post the workbook, it will help solving it.