Gustav Brock
Gustav at cactus.dk
Mon Mar 29 02:06:31 CDT 2010
Hi A.D.
Good question. It has really stumped me that such - what seems like a simple task - through the years has raised so many questions and resulted in so much buggy code, including several attempts from myself.
Counting age in days is extremely simple, you may think:
AgeDays = DateDiff("d", Date1, Date2)
However, this assumes that you ignore the hour of the day for the birth. To incorporate this, you could use a method like that for calculating the age in months:
<code>
Public Function AgeMonths( _
ByVal datDOB As Date, _
ByVal datNow As Date) _
As Integer
' Returns the difference in full months between datDOB and datNow.
'
' Calculates correctly for:
' leap years
' dates of 29. February
' date/time values with embedded time values
' negative date/time values (prior to 1899-12-29)
'
' Gustav Brock, Cactus Data ApS.
' 2008-06-28.
Dim intMonths As Integer
intMonths = DateDiff("m", datDOB, datNow)
intMonths = intMonths + (datNow < DateAdd("m", intMonths, datDOB))
AgeMonths = intMonths
End Function
</code>
The main problem when calculation age in years is that a month is not a month and a year is not a year. Both have varying count of days.
This can lead to many worries until you realise that the best method is to turn it upside down - by adding a found interval of years (age) to the first date to prove that the second date is the right. That could lead to a new problem if you should consider how to add years but that is not the case as VBA features the DateAdd function which calculates correctly. Thus:
Age = Years(Date1, Date2) <=> Date2 = DateAdd("yyyy", Age, Date1)
So the simple answer to your question is to apply DateAdd to check your calculation and correct when needed. After a lengthy discussion and input from several members at Experts Exchange which also introduced the topic "Linear Age", this is how it turned out:
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 Years( _
ByVal datDOB As Date, _
ByVal datNow As Date, _
Optional ByVal booLinear As Boolean) _
As Integer
' Returns the difference in full years between datDOB and datNow.
'
' 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 datDOB, if datNow 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 datDOB and datNow will return
' results of same absolute value, only the sign will change.
' This behaviour mimics that of Fix().
' If booLinear is True, reversing datDOB and datNow 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.
' 2008-04-27. Version 2.1.
' Correction for calculation of linear age from Feb. 29th.
' to Feb. 28th of a previous non-leap year as documented
' by Lester Hui.
'
' Example:
' DOB: 2000-02-29, Today: 1999-02-28, Age linear: -1.
'
' Parameters renamed to stress that for age calculations
' first parameter must be Date of Birth as documented
' by Markus G. Fischer.
' 2008-04-27. Version 2.2
' Rewrite to correct negative years count bug.
Dim intSign As Integer
Dim intYears As Integer
' Find difference in calendar years.
intYears = DateDiff("yyyy", datDOB, datNow)
' 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", datDOB, datNow) > 0 Then
If DateDiff("d", DateAdd("yyyy", intYears, datDOB), datNow) < 0 Then
' The last year is not a full year.
' Reduce year count by one.
intYears = intYears - 1
End If
Else
intSign = Sgn(DateDiff("d", DateAdd("yyyy", -intYears, datNow), datDOB))
If intSign <> 0 Then
If intSign < 0 Then
' The last year is not a full year.
' Reduce negative year count by one.
intYears = intYears + 1
End If
If booLinear Then
' Offset negative count of years to continuous sequence if requested.
If DateDiff("d", DateAdd("yyyy", intYears, datDOB), datNow) < 0 Then
' Time interval includes a partial year.
' Increase negative year count by one.
intYears = intYears - 1
End If
End If
End If
End If
' Return count of years as count of full 12 months periods.
Years = intYears
End Function
</code>
Note that if you cut the meat off, the function Years just use DateDiff and checks with DateAdd and corrects if necessary.
This function can do "everything" including calculate an age - positive or negative - you later can add with another age while keeping the correct sum.
Is "all this" really necessary, I have been asked, when so many quick and dirty methods exist out there? I say why not? This function does it right in any situation, and once copied to your code library module, it is just a function like any other function. Of course, to calculate the age of the members of the local pool club, who cares if one or two members miss a year? The World still stands. But for serious business use like insurance, pension, warranty, leasing, etc., it can be important to know that your calculation is always right. Remember that if you are not sure, you would do a manual calculation in those situations where doubt could exist, and that is waste of time.
/gustav
>>> adtp at airtelmail.in 29-03-2010 06:41 >>>
Feasibility of a universal function for calculation of date difference in terms of completed years, months and days has often featured in various discussion groups. It is also referred as age calculation function when second argument is optional and defaults to today's date.
Over the years, different flavors of such a function have been attempted. In this regard, it would be desirable to evolve a consensus as to the governing rules to be followed for computing the results.
Proposed draft guidelines are placed below (Let Dy1 & Dy2 be the day parts of start & end dates respectively. Let Dy represent days count in final result):
==========================================
1 - If both Dy1 & Dy2 represent ends of respective months, day part of the final result (Dy) is zero.
2 - If Dy2 is at the end of month and Dy1 is not, Dy equals unfinished days in start month.
3 - If Dy1 is at the end of month and Dy2 is not, Dy equals Dy2.
4 - If neither date represents end of the month, and Dy2 >= Dy1, result days (Dy) = Dy2 - Dy1.
5 - If neither date represents end of the month, and Dy2 < Dy1, result days (Dy) is computed by adding Dy2 and unfinished days in start month.
==========================================
It would be nice, if interested members could kindly examine the above and offer their considered views regarding modifications to the draft guidelines, as felt necessary.
Best wishes,
A.D. Tejpal
------------