A.D.TEJPAL
adtp at hotmail.com
Tue Jun 26 07:30:54 CDT 2007
Gustav,
Thanks for sharing with us. Very nice. Seems to be an evergreen topic.
Just to try my hand as well, an alternative function named Fn_AgeInFullYears() is given below. Could you kindly make it convenient to test it out and verify whether the results are consistent against all possible values of the date arguments ?
Best wishes,
A.D.Tejpal
---------------
Fn_AgeInFullYears()
================================
Function Fn_AgeInFullYears(ByVal _
DtOfBirth As Date, Optional _
ByVal DtUpto As Variant) As Long
' Gets Full years lapsed between two dates
' If start date is 29-Feb (leap year) and end
' date is 28-Feb in a non-leap year, it is
' assumed to mark a complete year.
Dim Dte1 As Date, Dte2 As Date
Dim Yr As Long, Dte As Date
Dim SignFactor As Long
If IsMissing(DtUpto) Then
Dte = Date
Else
Dte = IIf(IsDate(DtUpto), DtUpto, Date)
End If
Dte1 = IIf(Dte > DtOfBirth, DtOfBirth, Dte)
Dte2 = IIf(Dte > DtOfBirth, Dte, DtOfBirth)
SignFactor = IIf(Dte > DtOfBirth, 1, -1)
If Year(Dte2) = Year(Dte1) Then
Yr = 0
GoTo ExitPoint
End If
If Format(Dte2, "mmdd") >= _
Format(Dte1, "mmdd") Then
Yr = Year(Dte2) - Year(Dte1)
Else
Yr = Year(Dte2) - Year(Dte1) - 1
' Make correction if Dte1 is 29-Feb (leap yr)
' and Dte2 is 28 Feb (in a non-leap yr)
If Format(Dte1, "mmdd") = "0229" And _
Format(Dte2, "mmdd") = "0228" _
And Month(Dte2 + 1) = 3 Then
Yr = Yr + 1
End If
End If
ExitPoint:
Fn_AgeInFullYears = Yr * SignFactor
End Function
================================
----- Original Message -----
From: Gustav Brock
To: accessd at databaseadvisors.com
Sent: Saturday, June 23, 2007 23:26
Subject: [AccessD] Age calculation
Hi all
As I have posted several times, most of the functions published around the web for this simple task is crap because they fail for calculations around Feb. 28./29., thus they are not suited for business use.
Recently I noticed that DateAdd() correctly returns Feb. 28 when adding a count of years to dates of Feb. 29. resulting in dates of common years.
Markus G. Fischer at Expert-Exchange came up with the idea of using this feature for serious age calculation, and so I did.
I did a rewrite of my previous Years function as it could be simplified considerably using DateAdd and with the option to return negative ages in either of two ways.
For a given datDate1, if datDate2 is decreased step wise one year from returning a positive count to returning a negative count, one or two occurrences of count zero will be returned.
If booLinear is False, the sequence will be:
3, 2, 1, 0, 0, -1, -2
If booLinear is True, the sequence will be:
3, 2, 1, 0, -1, -2, -3
More explanation in the in-line comments.
Here it is:
Public Function Age( _
ByVal datDateOfBirth As Date, _
Optional ByVal varDate As Variant) _
As Integer
' Calculates age at today's date or at a specified date earlier or later in time.
' Uses Years() for calculating difference in years.
'
' Will return 0 for any varDate of the first year before datDateOfBirth.
' See comments for Years().
'
' 2000-11-03. Cactus Data ApS, CPH.
' 2007-06-23. Supplemented with AgeLinear for count of negative ages offset by -1.
Dim datDate As Date
' No special error handling.
On Error Resume Next
If IsDate(varDate) Then
datDate = CDate(varDate)
Else
datDate = Date
End If
Age = Years(datDateOfBirth, datDate)
End Function
Public Function AgeLinear( _
ByVal datDateOfBirth As Date, _
Optional ByVal varDate As Variant) _
As Integer
' Calculates age at today's date or at a specified date earlier or later in time.
' Uses Years() for calculating difference in years.
'
' Will return -1 for any varDate of the first year before datDateOfBirth.
' See comments for Years().
'
' 2007-06-23. Cactus Data ApS, CPH.
Dim datDate As Date
' No special error handling.
On Error Resume Next
If IsDate(varDate) Then
datDate = CDate(varDate)
Else
datDate = Date
End If
AgeLinear = Years(datDateOfBirth, datDate, True)
End Function
Public Function Years( _
ByVal datDate1 As Date, _
ByVal datDate2 As Date, _
Optional ByVal booLinear As Boolean) _
As Integer
' Returns the difference in full years between datDate1 and datDate2.
'
' Calculates correctly for:
' negative differences
' leap years
' dates of 29. February
' date/time values with embedded time values
' negative date/time values (prior to 1899-12-29)
'
' Optionally returns negative counts rounded down to provide a
' linear sequence of year counts.
' For a given datDate1, if datDate2 is decreased step wise one year from
' returning a positive count to returning a negative count, one or two
' occurrences of count zero will be returned.
' If booLinear is False, the sequence will be:
' 3, 2, 1, 0, 0, -1, -2
' If booLinear is True, the sequence will be:
' 3, 2, 1, 0, -1, -2, -3
'
' If booLinear is False, reversing datDate1 and datDate2 will return
' results of same absolute value, only the sign will change.
' This behaviour mimics that of Fix().
' If booLinear is True, reversing datDate1 and datDate2 will return
' results where the negative count is offset by -1.
' This behaviour mimics that of Int().
' DateAdd() is used for check for month end of February as it correctly
' returns Feb. 28. when adding a count of years to dates of Feb. 29.
' when the resulting year is a common year.
'
' 2000-11-03. Cactus Data ApS, CPH.
' 2000-12-16. Leap year correction modified to be symmetrical.
' Calculation of intDaysDiff simplified.
' Renamed from YearsDiff() to Years().
' 2000-12-18. Introduced cbytMonthDaysMax.
' 2007-06-22. Version 2. Complete rewrite.
' Check for month end of February performed with DateAdd()
' after idea of Markus G. Fischer.
Dim intDiff As Integer
Dim intSign As Integer
Dim intYears As Integer
' Find difference in calendar years.
intYears = DateDiff("yyyy", datDate1, datDate2)
' For positive resp. negative intervals, check if the second date
' falls before, on, or after the crossing date for a full 12 months period
' while at the same time correcting for February 29. of leap years.
If DateDiff("d", datDate1, datDate2) > 0 Then
intSign = Sgn(DateDiff("d", DateAdd("yyyy", intYears, datDate1), datDate2))
intDiff = Abs(intSign < 0)
Else
intSign = Sgn(DateDiff("d", DateAdd("yyyy", -intYears, datDate2), datDate1))
If intSign <> 0 Then
' Offset negative count of years to continuous sequence if requested.
intDiff = Abs(booLinear)
End If
intDiff = intDiff - Abs(intSign < 0)
End If
' Return count of years as count of full 12 months periods.
Years = intYears - intDiff
End Function
/gustav