' a Macro to calculate the age in years, months and days
' based on a birthdate entered in cell A2 and insert the
' age in cell A3
' Macro created 16/9/00 by Doug Robbins
'
Dim Years As Long
Dim Months As Long
Dim Days As Long
Dim Birthrange As Range
Dim Birthday As Long
Dim Day As Long
Dim Age As String
Dim Agedays As String
Dim Yearnow As Long
Dim Monthnow As Long
Monthnow = Val(Format(Date, "m"))
Yearnow = Val(Format(Date, "yyyy"))
Dim mon$(12)
mon$(1) = "January": mon$(2) = "February": mon$(3) = "March": mon$(4) =
"April": mon$(5) = "May": mon$(6) = "June": mon$(7) = "July": mon$(8) =
"August": mon$(9) = "September": mon$(10) = "October": mon$(11) =
"November": mon$(12) = "December"
Dim monthdays$(12)
If ((Yearnow Mod 4 = 0 And Calyear Mod 400 = 0) Or (Calyear Mod 4 = 0
And Calyear Mod 100 <> 0)) Then
monthdays$(1) = "31": monthdays$(2) = "29": monthdays$(3) = "31":
monthdays$(4) = "30": monthdays$(5) = "31": monthdays$(6) = "30":
monthdays$(7) = "31": monthdays$(8) = "31": monthdays$(9) = "30":
monthdays$(10) = "31": monthdays$(11) = "30": monthdays$(12) = "31"
Else
monthdays$(1) = "31": monthdays$(2) = "28": monthdays$(3) = "31":
monthdays$(4) = "30": monthdays$(5) = "31": monthdays$(6) = "30":
monthdays$(7) = "31": monthdays$(8) = "31": monthdays$(9) = "30":
monthdays$(10) = "31": monthdays$(11) = "30": monthdays$(12) = "31"
End If
Set Birthrange = ActiveDocument.Tables(1).Cell(1, 2).Range
Birthrange.End = Birthrange.End - 1
Birthdate = Birthrange
Years = DateDiff("yyyy", Birthdate, Date)
Months = DateDiff("m", Birthdate, Date) - Years * 12
Birthday = Format(Birthdate, "d")
Day = Format(Date, "d")
Days = Day - Birthday
If Days > 0 Then
Agedays = " and " & Format(Days) & " days."
ElseIf Days < 0 Then
Agedays = " and " & Format(monthdays$(Monthnow) - Birthday + Day) & "
days."
Months = Months - 1
Else
Agedays = "."
End If
Age = Format(Years) & " years, " & Format(Months) & " Months" & Agedays
ActiveDocument.Tables(1).Cell(1, 3).Range.Text = Age
--
Hope this helps.
Please reply to the newsgroup unless you wish to avail yourself of my
services on a paid consulting basis.
Doug Robbins - Word MVP
