[AccessD] Age calculation

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


More information about the AccessD mailing list