Calc Date Years Month Days from DOB to DOD

[Buddy]

Hi,
I'm trying to calc Years Months and Days from DOB to DOD. Years and Months
work, Days does not.
Can you help? Thanks Buddy - Problem also when DOB = 07/01/2006 DOD =
07/02/2006

'CALC Years
Function CalcAge(varDOB As Variant) As Integer
Dim varAge As Variant


If IsNull(varDOB) Then CalcAge = 0: Exit Function

varAge = DateDiff("yyyy", varDOB, xNow)
If Date < DateSerial(Year(xNow), Month(varDOB), Day(varDOB)) Then
varAge = varAge - 1
Else
End If
If xNow >= DateSerial(Year(xNow), Month(varDOB), Day(varDOB)) Then
CalcAge = CInt(varAge)
Else
'CalcAge = CInt(varAge)
End If
End Function

'CALC Months
Function CalcMonths(ByVal varDOB As String) As Integer

Dim tAge As Double
If IsNull(varDOB) Then tAge = 0: Exit Function
tAge = (DateDiff("m", varDOB, xNow))
If (DatePart("d", varDOB) > DatePart("d", xNow)) Then
tAge = tAge - 1
End If

If tAge < 0 Then
tAge = tAge + 1
End If
CalcMonths = CInt(tAge Mod 12)

End Function

'CALC Days
Function CalcDays(varDOB As Date) As Integer
Dim intDays As Integer

' Add one month, subtract dates to find difference.
intDays = DateSerial(Year(xNow), Month(xNow) - 1, Day(xNow)) _
- DateSerial(Year(varDOB), Month(varDOB), Day(varDOB))
CalcDays = intDays
'Debug.Print intDays

vDays = DateDiff("d", DateAdd("m", vMOnths, varDOB), xNow)
If IsNull(vDays) Then
vDays = 0
Else: End If
If vDays < 0 Then
' wierd way that DateDiff works, fix it here
'vMonths = vMonths - 1
vDays = DateDiff("d", DateAdd("m", vMOnths, varDOB), xNow)
End If
vYears = vMOnths \ 12 ' integer division
vMOnths = vMOnths Mod 12 ' only want leftover less than one year

End Function

 

[Duane Hookom]

Consider stealing Doug Steele's function at
http://www.accessmvp.com/djsteele/Diff2Dates.html.

 

[fredg]

Hi,
I'm trying to calc Years Months and Days from DOB to DOD. Years and Months
work, Days does not.
Can you help? Thanks Buddy - Problem also when DOB = 07/01/2006 DOD =
07/02/2006

'CALC Years
Function CalcAge(varDOB As Variant) As Integer
Dim varAge As Variant


If IsNull(varDOB) Then CalcAge = 0: Exit Function

varAge = DateDiff("yyyy", varDOB, xNow)
If Date < DateSerial(Year(xNow), Month(varDOB), Day(varDOB)) Then
varAge = varAge - 1
Else
End If
If xNow >= DateSerial(Year(xNow), Month(varDOB), Day(varDOB)) Then
CalcAge = CInt(varAge)
Else
'CalcAge = CInt(varAge)
End If
End Function

'CALC Months
Function CalcMonths(ByVal varDOB As String) As Integer

Dim tAge As Double
If IsNull(varDOB) Then tAge = 0: Exit Function
tAge = (DateDiff("m", varDOB, xNow))
If (DatePart("d", varDOB) > DatePart("d", xNow)) Then
tAge = tAge - 1
End If

If tAge < 0 Then
tAge = tAge + 1
End If
CalcMonths = CInt(tAge Mod 12)

End Function

'CALC Days
Function CalcDays(varDOB As Date) As Integer
Dim intDays As Integer

' Add one month, subtract dates to find difference.
intDays = DateSerial(Year(xNow), Month(xNow) - 1, Day(xNow)) _
- DateSerial(Year(varDOB), Month(varDOB), Day(varDOB))
CalcDays = intDays
'Debug.Print intDays

vDays = DateDiff("d", DateAdd("m", vMOnths, varDOB), xNow)
If IsNull(vDays) Then
vDays = 0
Else: End If
If vDays < 0 Then
' wierd way that DateDiff works, fix it here
'vMonths = vMonths - 1
vDays = DateDiff("d", DateAdd("m", vMOnths, varDOB), xNow)
End If
vYears = vMOnths \ 12 ' integer division
vMOnths = vMOnths Mod 12 ' only want leftover less than one year

End Function

See "A More Complete DateDiff Function" at
http://www.accessmvp.com/djsteele/Diff2Dates.html