Hi Andy,
Someone else asked for this about 4 years ago.
' a Macro created by Doug Robbins 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
'
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
--
Please respond to the Newsgroup for the benefit of others who may be
interested. Questions sent directly to me will only be answered on a paid
consulting basis.
Hope this helps,
Doug Robbins - Word MVP
