Current Age

[kapzlok]

I have a column with a person's date of birth listed. I was wondering if there is some function that I could use which would return the person's current age based on his/her birthdate and the current date, which would update for each day?

 

[traingamer]

See thread702-819256 as well as many other threads on this subject. Search the fora for current age or age calculation ...

Greg
"Personally, I am always ready to learn, although I do not always like being taught." - Winston Churchill

 

[THWatson]

kapzlok
Here is something complete that you can paste into a module and then where you want to use it call the function ShowAge.

Sub CompAge(ByVal varDate1, ByVal varDate2, _
  ByRef lngYears As Long, ByRef lngMonths As Long, _
  ByRef lngWeeks As Long, ByRef lngDays As Long)

  If IsNull(varDate1) Or IsNull(varDate2) Then
    Exit Sub
  End If

  If Not IsDate(varDate1) Or Not IsDate(varDate2) Then
    Exit Sub
  End If

  varDate1 = CDate(varDate1)
  varDate2 = CDate(varDate2)

  If varDate2 < varDate1 Then
    Exit Sub
  End If

  lngYears = Year(varDate2) - Year(varDate1)
  lngMonths = Month(varDate2) - Month(varDate1)
  lngDays = Day(varDate2) - Day(varDate1)
  If lngMonths < 0 Or lngMonths = 0 And lngDays < 0 Then
    lngYears = lngYears - 1
  End If

  varDate1 = DateAdd("yyyy", lngYears, varDate1)
  lngMonths = DateDiff("m", varDate1, varDate2)
  lngDays = Day(varDate2) - Day(varDate1)
  If lngDays < 0 Then
    lngMonths = lngMonths - 1
  End If

  varDate1 = DateAdd("m", lngMonths, varDate1)
  lngDays = varDate2 - varDate1
  lngWeeks = lngDays \ 7
  lngDays = lngDays Mod 7
End Sub

Function Plural(lngNum As Long, strWord As String) As String
  Plural = lngNum & " " & strWord
  If Not lngNum = 1 Then
    Plural = Plural & "s"
  End If
End Function

Function ShowAge(varDOB) As String
  Dim lngYears As Long
  Dim lngMonths As Long
  Dim lngWeeks As Long
  Dim lngDays As Long
  If IsNull(varDOB) Then
    Exit Function
  End If
  If Not IsDate(varDOB) Then
    Exit Function
  End If
  If Date < CDate(varDOB) Then
    Exit Function
  End If
  CompAge CDate(varDOB), Date, lngYears, lngMonths, lngWeeks, lngDays
  If lngYears < 1 Then
  ShowAge = IIf(lngMonths < 1, "", Plural(lngMonths, "Month") & ", ") _
        & IIf(lngWeeks < 1, "", Plural(lngWeeks, "Week")) _
        & IIf(lngDays < 1, "", " and " & Plural(lngDays, "Day"))

  '  ShowAge = Plural(lngMonths, "Month") & ", " & Plural(lngWeeks, "Week") & _
      " and " & Plural(lngDays, "Day")
  ElseIf lngYears < 3 Then
  ShowAge = Plural(lngYears, "Year") & IIf(lngMonths < 1, "", ", " & Plural(lngMonths, "Month")) _
        & IIf(lngWeeks < 1, "", " and " & Plural(lngWeeks, "Week"))
  '  ShowAge = Plural(lngYears, "Year") & ", " & Plural(lngMonths, "Month") & _
      " and " & Plural(lngWeeks, "Week")
  Else
    'ShowAge = Plural(lngYears, "Year") & " and " & Plural(lngMonths, "Month")
    ShowAge = Plural(lngYears, "Year")
  End If
End Function

Edit it as necessary.

Tom

 

[MichaelRed]

many other threads on this subject. Search the fora for current age or age calculation ...

Take two and you WILL feel better in the morning ...

(p.s. following the twice told tale provides both a simplier soloution and an excellent exercise in learning about the site (particularly search) and VB(A).)





MichaelRed

 

[ZmrAbdulla]

I'd suggest this (DateDiff Function thread222-980984)

________________________________________
Zameer Abdulla
Visit Me
A child may not be able to lift too much.
But it can certainly hold a marriage together

 

[kapzlok]

Thanks for your help. I ended up just using this simple code in the form itself and it seems to do the trick:

=DateDiff("yyyy",[DOB],Date())+(Date()<DateSerial(Year(Date()),Month([DOB]),Day([DOB])))