Help with macro for pre 1900 dates

Redstick

New Member
Joined
Oct 8, 2020
Messages
4
Office Version
  1. 365
Platform
  1. Windows
I'm working on my family history and therefore often have to deal with dates that are before 1900. I have found the microsoft Agefunc macro that I can use to calculate age in years but I would like to have ages displayed as Years, Months, Days. I can do that already for dates after 01/01/1900 by using the Datedif function but I would like to combine the to functions so I can display the exact age for people born before 1900.

I'm a complete novice when it comes to formulae and macros but with a bit of help and perciverance, I usually get there in the end :)

The formula I use for post 1900 dates is =DATEDIF(Birth,Death,"Y")&" Y, "&DATEDIF(Birth,Death,"YM")&" M, "&DATEDIF(Birth,Death,"MD")&" D" which will return a value such as 64 y, 11 M, 4 D
what I would like to do (if it's possible) is to integrate the Agefunc into the above Datedif formula so I can get the same Year, Month, Day result for pre 1900 dates.

Is this possible?

The Agefunc macro is below and I have edited it to allow dates to be entered in UK format of DD, MM, YYYY (the month and day have to be entered as 2 digits or errors occur)

VBA Code:
' This is the initial function. It takes in a start date and an end date.
Public Function AgeFunc(stdate As Variant, endate As Variant)

    ' Dim our variables.
    Dim stvar As String
    Dim stmon As String
    Dim stday As String
    Dim styr As String
    Dim endvar As String
    Dim endmon As String
    Dim endday As String
    Dim endyr As String
    Dim stmonf As Integer
    Dim stdayf As Integer
    Dim styrf As Integer
    Dim endmonf As Integer
    Dim enddayf As Integer
    Dim endyrf As Integer
    Dim years As Integer

    ' This variable will be used to modify string length.
    Dim fx As Integer
    fx = 0

    ' Calls custom function sfunc which runs the Search worksheet function
    ' and returns the results.
    ' Searches for the first "/" sign in the start date.
    stvar = sfunc("/", stdate)

    ' Parse the month and day from the start date.
    stday = Left(stdate, sfunc("/", stdate) - 1)
    stmon = Mid(stdate, stvar + 1, sfunc("/", stdate, sfunc("/", stdate) + 1) - stvar - 1)

    ' Check the length of the day and month strings and modify the string
    ' length variable.
    If Len(stday) = 1 Then fx = fx + 1
    If Len(stmon) = 2 Then fx = fx + 1

    ' Parse the year, using information from the string length variable.
    styr = Right(stdate, Len(stdate) - (sfunc("/", stdate) + 1) - stvar + fx)

    ' Change the text values we obtained to integers for calculation
    ' purposes.
    stmonf = CInt(stmon)
    stdayf = CInt(stday)
    styrf = CInt(styr)

    ' Check for valid date entries.
    If stmonf < 1 Or stmonf > 12 Or stdayf < 1 Or stdayf > 31 Or styrf < 1 Then
        AgeFunc = "Invalid Date"
        Exit Function
    End If

    ' Reset the string length variable.
    fx = 0

    ' Parse the first "/" sign from the end date.
    endvar = sfunc("/", endate)

   ' Parse the month and day from the end date.
    endday = Left(endate, sfunc("/", endate) - 1)
    endmon = Mid(endate, endvar + 1, sfunc("/", endate, sfunc("/", endate) + 1) - endvar - 1)

    ' Check the length of the day and month strings and modify the string
    ' length variable.
    If Len(endday) = 1 Then fx = fx + 1
    If Len(endmon) = 2 Then fx = fx + 1

    ' Parse the year, using information from the string length variable.
    endyr = Right(endate, Len(endate) - (sfunc("/", endate) + 1) - endvar + fx)

    ' Change the text values we obtained to integers for calculation
    ' purposes.
    endmonf = CInt(endmon)
    enddayf = CInt(endday)
    endyrf = CInt(endyr)

    ' Check for valid date entries.
    If endmonf < 1 Or endmonf > 12 Or enddayf < 1 Or enddayf > 31 Or endyrf < 1 Then
        AgeFunc = "Invalid Date"
        Exit Function
    End If

    ' Determine the initial number of years by subtracting the first and
    ' second year.
    years = endyrf - styrf

    ' Look at the month and day values to make sure a full year has passed.
    If stmonf > endmonf Then
        years = years - 1
    End If

If stmonf = endmonf And stdayf > enddayf Then
        years = years - 1
    End If

    ' Make sure that we are not returning a negative number and, if not,
    ' return the years.
    If years < 0 Then
        AgeFunc = "Invalid Date"
    Else
        AgeFunc = years
    End If

End Function

' This is a second function that the first will call.
' It runs the Search worksheet function with arguments passed from AgeFunc.
' It is used so that the code is easier to read.
Public Function sfunc(x As Variant, y As Variant, Optional z As Variant)
    sfunc = Application.WorksheetFunction.Search(x, y, z)
End Function


I know I'm asking a lot but, if anybody would like to take on a challenge and help me figure this out, I'd be very grateful

Redstick
 
Last edited by a moderator:

Some videos you may like

Excel Facts

Using Function Arguments with nested formulas
If writing INDEX in Func. Arguments, type MATCH(. Use the mouse to click inside MATCH in the formula bar. Dialog switches to MATCH.

Taul

Well-known Member
Joined
Oct 24, 2004
Messages
734
Office Version
  1. 2019
  2. 2013
Platform
  1. Windows
Hi,
I use a formula for my ancestry data for dates pre 1900, using the following headers in row 1:-
A1 = Name
B1 = DoB
C1 = Died
D1= Age

In cell D2 use this formula:-

Code:
=IF(ISBLANK(B2),"-",IF(ISBLANK(C2),"-",DATEDIF(IF(ISTEXT(B2),DATEVALUE(LEFT(B2,LEN(B2)-4)&RIGHT(B2,4)+1000),EDATE(B2,12000)),IF(ISTEXT(C2),DATEVALUE(LEFT(C2,LEN(C2)-4)&RIGHT(C2,4)+1000),EDATE(C2,12000)),"y")&" y "&DATEDIF(IF(ISTEXT(B2),DATEVALUE(LEFT(B2,LEN(B2)-4)&RIGHT(B2,4)+1000),EDATE(B2,12000)),IF(ISTEXT(C2),DATEVALUE(LEFT(C2,LEN(C2)-4)&RIGHT(C2,4)+1000),EDATE(C2,12000)),"ym") &" m " &DATEDIF(IF(ISTEXT(B2),DATEVALUE(LEFT(B2,LEN(B2)-4)&RIGHT(B2,4)+1000),EDATE(B2,12000)),IF(ISTEXT(C2),DATEVALUE(LEFT(C2,LEN(C2)-4)&RIGHT(C2,4)+1000),EDATE(C2,12000)),"md")&" d "))

It is adapted formula but the original formula came from this site and the output is in the form of
88 y 6 m 15 d

http://www.exceluser.com/formulas/earlydates.htm

There is an interesting article about the pitfalls of going back too far with the dates, it’s worth a read.
It also has a macro equivalent to download. I have not used the macro so I can’t say much about it.
Hope this helps

Paul.
 

Redstick

New Member
Joined
Oct 8, 2020
Messages
4
Office Version
  1. 365
Platform
  1. Windows
Hi Paul, Thanks for the quick reply
Thanks for the link, it is something I have already looked at and the macro is the one I gave in my first post.

I have tried your formula and of course, it works, :) however, I have a question, can it be modified to give a result if "C2" is blank, i.e. return an age if the person was still alive?
I know almost everybody born before 1900 will now be dead but if it can be modified it would mean the formula could be used for all age calculations e.g. Pre and Post 1900 and dead or alive.
 

Taul

Well-known Member
Joined
Oct 24, 2004
Messages
734
Office Version
  1. 2019
  2. 2013
Platform
  1. Windows
Hi,

Ok, this may be a bit clumsy but it appears to work

Code:
 =IF(ISBLANK(B2),"-",IF(ISBLANK(C2),DATEDIF(IF(ISTEXT(B2),DATEVALUE(LEFT(B2,LEN(B2)-4)&RIGHT(B2,4)+1000),EDATE(B2,12000)),IF(ISTEXT(TODAY()),DATEVALUE(LEFT(TODAY(),LEN(TODAY())-4)&RIGHT(TODAY(),4)+1000),EDATE(TODAY(),12000)),"y")&" y "&DATEDIF(IF(ISTEXT(B2),DATEVALUE(LEFT(B2,LEN(B2)-4)&RIGHT(B2,4)+1000),EDATE(B2,12000)),IF(ISTEXT(TODAY()),DATEVALUE(LEFT(TODAY(),LEN(TODAY())-4)&RIGHT(TODAY(),4)+1000),EDATE(TODAY(),12000)),"ym")&" m "&DATEDIF(IF(ISTEXT(B2),DATEVALUE(LEFT(B2,LEN(B2)-4)&RIGHT(B2,4)+1000),EDATE(B2,12000)),IF(ISTEXT(TODAY()),DATEVALUE(LEFT(TODAY(),LEN(TODAY())-4)&RIGHT(TODAY(),4)+1000),EDATE(TODAY(),12000)),"md")&" d ",DATEDIF(IF(ISTEXT(B2),DATEVALUE(LEFT(B2,LEN(B2)-4)&RIGHT(B2,4)+1000),EDATE(B2,12000)),IF(ISTEXT(C2),DATEVALUE(LEFT(C2,LEN(C2)-4)&RIGHT(C2,4)+1000),EDATE(C2,12000)),"y")&" y "&DATEDIF(IF(ISTEXT(B2),DATEVALUE(LEFT(B2,LEN(B2)-4)&RIGHT(B2,4)+1000),EDATE(B2,12000)),IF(ISTEXT(C2),DATEVALUE(LEFT(C2,LEN(C2)-4)&RIGHT(C2,4)+1000),EDATE(C2,12000)),"ym")&" m "&DATEDIF(IF(ISTEXT(B2),DATEVALUE(LEFT(B2,LEN(B2)-4)&RIGHT(B2,4)+1000),EDATE(B2,12000)),IF(ISTEXT(C2),DATEVALUE(LEFT(C2,LEN(C2)-4)&RIGHT(C2,4)+1000),EDATE(C2,12000)),"md")&" d "))

edit - put the formula in cell D2
 

Redstick

New Member
Joined
Oct 8, 2020
Messages
4
Office Version
  1. 365
Platform
  1. Windows

ADVERTISEMENT

Thanks for that.
I'm not sure what's wrong but, when I paste the formula into my sheet it is displayed at text, it does not work as a formula (all other formulas work normally)
 

Taul

Well-known Member
Joined
Oct 24, 2004
Messages
734
Office Version
  1. 2019
  2. 2013
Platform
  1. Windows
Hi,
I just replicated copy paste from the website and it works ok for me.
Are you sure you copied the whole formula, pasting as text may happen if the "=" sign is missing
 

Redstick

New Member
Joined
Oct 8, 2020
Messages
4
Office Version
  1. 365
Platform
  1. Windows
I've found the problem :)
There was a space before the =
Works perfectly - Thank You.
 

Taul

Well-known Member
Joined
Oct 24, 2004
Messages
734
Office Version
  1. 2019
  2. 2013
Platform
  1. Windows
Good to know, I thought it would be something like that.
 

Watch MrExcel Video

Forum statistics

Threads
1,114,492
Messages
5,548,362
Members
410,828
Latest member
A9Bosv3
Top