Gregorian Period 100-1900 and Aging

[Please_H]

Dear All,

Just like my previous inquiry i have a set of Data on the early Gregorian years starting from 100-1900.
What is the best way to make the excel understand and format them under dd/mm/yyyyy and do an aging with =today()

Thank you.

 

[Please_H]

I did find this as a solution,
Not sure if it works for Gregorian Years below 1000....

I tried their own example given in the thread,
but I am getting "#value!" error instead 58...

How to calculate ages before January 1, 1900 in Excel - Microsoft 365 Apps

Describes how to use Macro to calculate age before January 1, 1900 in Excel.

docs.microsoft.com

the VB,

' 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.
stmon = Left(stdate, sfunc("/", stdate) - 1)
stday = 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.
endmon = Left(endate, sfunc("/", endate) - 1)
endday = 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

 

[Please_H]

I found another solution from a paid website which allows us to get some free info from some parts of their threads...

This is the VBA which was allowed to gather for free...

Solved: Excel 2010 - Date arithmetic BEFORE 1900 (1774 up to 1900) | Experts Exchange

Find answers to Excel 2010 - Date arithmetic BEFORE 1900 (1774 up to 1900) from the expert community at Experts Exchange

www.experts-exchange.com

Option Explicit

' change the sequence of these 3 enumerations to match the
' sequence in which you write day, month & year in your dates
Enum Nds ' Date sequence
NdsDay
NdsMonth
NdsYear
End Enum

Const DateSeparator As String = "/"

Function DATESERIAL(Cell As Range)
' UDF for use in worksheets

Dim CellDat() As Long

CellDat = GetDate(Cell.Value)
DATESERIAL = HDATESERIAL(CellDat(NdsYear), _
CellDat(NdsMonth), _
CellDat(NdsDay))
End Function

Function YEARDIFF(Acell As Range, _
Bcell As Range) As Long
YEARDIFF = Int(MONTHDIFF(Acell, Bcell) / 12)
End Function

Function MONTHDIFF(Acell As Range, _
Bcell As Range) As Long

Dim Adate() As Long
Dim Bdate() As Long
Dim Md As Long
Dim Yd As Long

Adate = GetDate(Acell.Value)
Bdate = GetDate(Bcell.Value)

Md = IIf(Bdate(NdsDay) < Adate(NdsDay), 1, 0)
If Bdate(NdsMonth) < Adate(NdsMonth) Or _
(Bdate(NdsMonth) = Adate(NdsMonth) And Md > 0) _
Then Yd = 1

MONTHDIFF = Int((Bdate(NdsYear) - Adate(NdsYear) - Yd) * 12) _
+ ((Bdate(NdsMonth) + 12 - Adate(NdsMonth) - Md) Mod 12)
End Function

Function DAYDIFF(Acell As Range, _
Bcell As Range) As Long

Dim Mdays() As Variant
Dim Adate() As Long
Dim Bdate() As Long

Mdays = Array(0, 31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31)
Adate = GetDate(Acell.Value)
Bdate = GetDate(Bcell.Value)

DAYDIFF = IIf(Bdate(NdsDay) < Adate(NdsDay), _
Mdays(Adate(NdsMonth)) - Adate(NdsDay) + 1 + Bdate(NdsDay), _
Bdate(NdsDay) - Adate(NdsDay))
End Function

Private Function GetDate(TxtDate As String) As Long()

Dim Txt() As String
Dim Gd(2) As Long
Dim i As Integer

Txt = Split(TxtDate, DateSeparator)
For i = 0 To 2
Gd(i) = CLng(Val(Txt(i)))
Next i
GetDate = Gd
End Function

Function HDATESERIAL(ByVal HYear As Long, ByVal HMonth As Long, ByVal HDay As Long) As Long

Dim Mdays() As Variant
Dim Years As Long
Dim Months As Long
Dim Days As Long
Dim i As Integer

Months = HMonth Mod 12
Years = HYear + Int(Months / 12)
Mdays = Array(0, 31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31)
For i = 0 To HMonth - 1
Days = Days + Mdays(i)
Next i
If Months > 2 And (Years Mod 4) = 0 Then
If (Years Mod 400) Then Days = Days + 1
End If
HDATESERIAL = (Years * 365) + Int(Years / 4) - Int(Years / 400) _
+ Days + HDay
End Function

Function HWEEKDAY(ByVal Days As Long, _
Optional ByVal FirstDayOfWeek As VbDayOfWeek = vbSunday) _
As Integer

Dim Hd As Long

Hd = (Weekday(Days, FirstDayOfWeek) + 4)
HWEEKDAY = Hd - IIf(Hd > 7, 7, 0)
End Function

But another user had pointed out that leap years and a jump of 10 days made in 1582 isn't adjusted in this UDF...