Age calculation in Text Format, in year, month and day.

[harzer]

I am facing a problem despite my research on the net, I confess that I can not find it.
Namely that I am unable to handle array variables correctly, which complicates my task.

I have a large amount of row data, in 10 columns, the ones that concern the present case, are columns E and H.
for now, column E is empty.
Column H contains dates of birth.
How to proceed, either by table or table combined with dictionary to indicate the age in: year, month and days in column E, according to the current date.
The goal is to have the result in text format, (Example: 15y 5m 10d), I thought of making a call to a function which would give the result just in text so as not to use formulas (No formulas) Please .
Unless I am mistaken, the desired result for the first 10 lines is in column L, based on the date that the calculation was made is: 30-01-2023
Thank you very much in advance for your suggestions.
PS: I completely emptied my table and I simply left the two columns concerned so that you can (eventually) test your code.

CalculAge1.xlsm
	A	B	C	D	E	F	G	H	I	J	K	L	M
1					Age			Né(e)				Age
2								16-03-1957				65 a 10 m 14 j
3								17-04-2012				10 a 9 m 13 j
4								14-04-2012				10 a 9 m 16 j
5								25-03-1966				56 a 10 m 5 j
6								30-05-1959				63 a 8 m 0 j
7								17-02-1962				60 a 11 m 13 j
8								22-01-1955				68 a 0 m 8 j
9								15-02-1961				61 a 11 m 15 j
10								18-04-2012				10 a 9 m 12 j
11								1-01-2010				13 a 0 m 29 j
12								22-03-2019
13								15-04-2007
14								15-04-2007
15								15-04-2007
16								16-04-2007
17								15-04-2008
18								15-04-2008
19								15-04-2008
20								15-04-2008
21								15-04-2008
22								15-04-2008
23								15-04-2008
24								15-05-2008
25								15-04-2008
Parents

 

[James006]

Uniquement pour en avoir le coeur net ...
Est ce que la fonction corrigée ci-dessous fonctionne correctement pour le test de la cellule L2

Function Age(rng As Range)
' Dans la cellule L2 saisir = age(H2)
  Age = Evaluate("=DATEDIF(" & CLng(rng.Value) & ",TODAY(),""y"")&"" a ""&DATEDIF(" & CLng(rng.Value) & ",TODAY(),""ym"")&"" m ""&DATEDIF(" & CLng(rng.Value) & ",TODAY(),""md"")&"" j """)
End Function

 

[Fluff]

@James006 Please post in English only on this board. Thanks

 

[James006]

@Fluff You are 100 % right !!!

To be on the safe side...
Is the revised UDF working properly for cell L2 ...

 

[harzer]

The revised UDF does not work either, I have the following results: #VALUE!

 

[James006]

So, if you would just recap :

1. The UDF does not work
and
2. The exact same formula =DATEDIF(H2,TODAY(),"y")&" a "&DATEDIF(H2,TODAY(),"ym")&" m "&DATEDIF(H2,TODAY(),"md")&" j "
does produce the L2 result : 65 a 10 m 14 j

Is that right ?

 

[James006]

Could it be just the French version of Excel ...?
What about testing the following local adjustment :

=DATEDIF(H2;AUJOURDHUI();"y")&" a "&DATEDIF(H2;AUJOURDHUI();"ym")&" m "&DATEDIF(H2;AUJOURDHUI(),"md")&" j "

 

[harzer]

Hello,
the formula :
=DATEDIF(H2,TODAY(),"y")&" a "&DATEDIF(H2,TODAY(),"ym")&" m "&DATEDIF(H2,TODAY(),"md")&" j " ---> Excel tells me that there is an error in the formula.
And with the formula :
=DATEDIF(H2;AUJOURDHUI();"y")&" a "&DATEDIF(H2;AUJOURDHUI();"ym")&" m "&DATEDIF(H2;AUJOURDHUI(),"md")&" j " ---> Excel shows me the same message that there is an error in the formula.
I propose something to you, I managed to make a code that gives me the desired result (to be linked with a button) but it is not fast enough in my real file, here is the code:

Sub CalculAge()
    Application.ScreenUpdating = False
    Dim Y As Integer, j As Integer
    Dim M As Integer
    Dim D As Integer
    Dim Temp1 As Date
   

    With Sheets("Parents")
            lastRow = .Cells(.Rows.Count, "H").End(xlUp).Row                                                                                                           '#

            For j = 2 To lastRow                     'boucle sur les lignes : de la 2e ligne jusqu'à la dernière

                    Date1 = .Cells(j, "H").Value     'on met la date de naissance (Colonne "H") dans "Date"
                    Date2 = Date

                    Temp1 = DateSerial(Year(Date2), Month(Date1), Day(Date1))
                    Y = Year(Date2) - Year(Date1) + (Temp1 > Date2)
                    M = Month(Date2) - Month(Date1) - (12 * (Temp1 > Date2))
                    D = Day(Date2) - Day(Date1)
   
                            If D < 0 Then
                                    M = M - 1
                                    D = Day(DateSerial(Year(Date2), Month(Date2) + 1, 0)) + D + 1
                            End If

                    Age = Y & " a " & M & " m " & D & " j"
                    .Cells(j, "E").Value = Age
            Next j                                                                                                                                                   '#
    End With
    Application.ScreenUpdating = True
End Sub

Can you modify it to be processed by arrays to speed up the execution speed of the Macro.
I await an answer from both of you.
Thanks in advance.

 

[harzer]

I forgot to specify to mention that I was inspired by a code resembling my needs.

 

[Alex Blakenburg]

This is a straight conversion of your code from updating 1 cell at a time to using an array.

Sub CalculAge()
    Application.ScreenUpdating = False
    Dim Y As Integer, j As Integer
    Dim M As Integer
    Dim D As Integer
    Dim Temp1 As Date
    Dim wsParents As Worksheet
    Dim rngDate As Range
    Dim arrDate As Variant
    Dim lastRow As Long
    Dim Date1 As Long, DateCurrent As Long
    
    Set wsParents = Worksheets("Parents")
    With wsParents
            lastRow = .Cells(.Rows.Count, "H").End(xlUp).Row                                 '#
            Set rngDate = .Range(.Cells(2, "H"), .Cells(lastRow, "H"))
            arrDate = rngDate.Value2
            ReDim Preserve arrDate(1 To UBound(arrDate, 1), 1 To 2)
    End With
            
    DateCurrent = CLng(Date)
    For j = 1 To UBound(arrDate)                        'boucle sur les lignes : de la 2e ligne jusqu'à la dernière

            Date1 = arrDate(j, 1)               'on met la date de naissance (Colonne "H") dans "Date"

            Temp1 = DateSerial(Year(DateCurrent), Month(Date1), Day(Date1))
            Y = Year(DateCurrent) - Year(Date1) + (Temp1 > DateCurrent)
            M = Month(DateCurrent) - Month(Date1) - (12 * (Temp1 > DateCurrent))
            D = Day(DateCurrent) - Day(Date1)

                    If D < 0 Then
                            M = M - 1
                            D = Day(DateSerial(Year(DateCurrent), Month(DateCurrent) + 1, 0)) + D + 1
                    End If

            arrDate(j, 2) = Y & " a " & M & " m " & D & " j"
    Next j                                                                                                                                                   '#

    rngDate.Offset(, -3).Value2 = Application.Index(arrDate, 0, 2)
    
    Application.ScreenUpdating = True
End Sub

 

[James006]

As far as speed is concerned

Sub CalcAges()
Dim i As Long, lr As Long
Dim arr()
lr = ActiveSheet.Range("H" & Rows.Count).End(xlUp).Row
ReDim arr(0 To lr - 2)
' Populate Array with Evaluate
    For i = 0 To lr - 2
        arr(i) = Evaluate("=DATEDIF(" & CLng(Cells(i + 2, 8).Value) & ",TODAY(),""y"")&"" a ""&DATEDIF(" & CLng(Cells(i + 2, 8).Value) & ",TODAY(),""ym"")&"" m ""&DATEDIF(" & CLng(Cells(i + 2, 8).Value) & ",TODAY(),""md"")&"" j """)
    Next i
' Display Results
ActiveSheet.Range("L2").Resize(UBound(arr) + 1).Value = Application.Transpose(arr)
End Sub