Microsoft 365 VBA : fonction qui calcule une durée entre 2 dates en années, mois et jours

[BenHarber]

Bonjour le Forum,
Sur une feuille Excel, je saisis une date en F3 (ex : date de naissance d'une personne) et ma cellule F4 me restitue l'âge de celle-ci à ce jour grâce à cette formule : =DATEDIF($F3;AUJOURDHUI();"y")&" ans, "&DATEDIF($F3;AUJOURDHUI();"ym")&" mois et "&DATEDIF($F3;AUJOURDHUI();"md")&" jours".

Savez-vous s'il existe son équivalent en VBA ? J'ai essayé avec la fonction DATEDIFF (avec 2 F) mais a priori, avec cette formule, les paramètres "ym" et "md" n'existent pas...

Merci d'avance pour vos idées et suggestions !
BH

 

[sylvanu]

Bonsoir HenHarber,
Effectivement ces param n'existent pas en VBA.
Par contre vous pouvez faire de façon très trivial :

Sub Macro2()
    [A1].Formula = _
        "=DATEDIF(F3,TODAY(),""y"")&"" ans, ""&DATEDIF(F3,TODAY(),""ym"")&"" mois et ""&DATEDIF(F3,TODAY(),""md"")&"" jours"""
    [A1] = [A1].Value
End Sub

Avec Date en F3 et résultat en A1. ( à ajuster bien évidemment )

 

[vgendron]

Hello
ci-dessous, le code d'une fonction personalisée

Function QuelAge(d1 As Date, Optional d2, Optional Précision) As String
Dim a&, m&, s&, j&
'précision: détermine le niveau de détail de l'age: j, s, m, a
    If IsMissing(Précision) Then Précision = "j"
    If IsMissing(d2) Then d2 = Now()
    If d1 > d2 Then QuelAge = "La 2ème date doit nécessairement être plus grande que la 1ère !"

    If (d1 > 60) * (d1 <= d2) Then
        Do While DateSerial(Year(d1) + a + 1, Month(d1), Day(d1)) <= d2: a = a + 1: Loop
        If Précision = "a" Then
            QuelAge = a & " an" & IIf(a > 1, "s", "")
            Exit Function
        End If
        
        Do While DateSerial(Year(d1) + a, Month(d1) + m + 1, Day(d1)) <= d2: m = m + 1: Loop
        If Précision = "m" Then
            QuelAge = IIf(a, a & " an" & IIf(a > 1, "s", "") & " ", "") & IIf(m, m & " mois ", "")
            Exit Function
        End If
        
        Do While DateSerial(Year(d1) + a, Month(d1) + m, Day(d1) + (s + 1) * 7) <= d2: s = s + 1: Loop
        If Précision = "s" Then
            QuelAge = IIf(a, a & " an" & IIf(a > 1, "s", "") & " ", "") & IIf(m, m & " mois ", "") & IIf(s, s & " semaine" & IIf(s > 1, "s", "") & " ", "")
            Exit Function
        End If
        
        Do While DateSerial(Year(d1) + a, Month(d1) + m, Day(d1) + s * 7 + j + 1) <= d2: j = j + 1: Loop
        QuelAge = IIf(a, a & " an" & IIf(a > 1, "s", "") & " ", "") & IIf(m, m & " mois ", "") & IIf(s, s & " semaine" & IIf(s > 1, "s", "") & " ", "") & IIf(j Or (a + m + j = 0), j & " jour" & IIf(j > 1, "s", ""), "")
    End If
End Function

 

[sylvanu]

Re, bonsoir Vgendron,
Comme généralement c'est utilisé pour toute une liste, un ex en PJ avec :

Sub Essai()
DL = Cells(Cells.Rows.Count, "A").End(xlUp).Row ' Adapter avec la plage de dates
With Range("B2:B" & DL)                  ' Adapter avec la plage résultats
.Formula = _
        "=DATEDIF(A2,TODAY(),""y"")&"" ans, ""&DATEDIF(A2,TODAY(),""ym"")&"" mois et ""&DATEDIF(A2,TODAY(),""md"")&"" jours"""
        ' Adapter le A2 avec la première cellule de la plage dates.
.Value = .Value ' A supprimer si on veut garder les formules, à conserver si on veut avoir que les valeurs.
End With
End Sub

 

[laurent950]

Bonsoir @BenHarber @sylvanu @vgendron

Function DureeEntreDates(d1 As Date, d2 As Date) As String
    Dim years As Integer, months As Integer, days As Integer
    Dim tmp As Date
    If d1 > d2 Then: tmp = d1: d1 = d2: d2 = tmp ' S'assurer que d1 est antérieure à d2
    years = Year(d2) - Year(d1): months = Month(d2) - Month(d1): days = Day(d2) - Day(d1)
    If days < 0 Then: months = months - 1: days = days + Day(DateSerial(Year(d2), Month(d2), 0))
    If months < 0 Then: years = years - 1: months = months + 12
    DureeEntreDates = years & " ans, " & months & " mois, " & days & " jours"
End Function

 

[patricktoulon]

bonsoir

Date et heure Discussion 'DATEDIFF_AMJ4'

4 Juillet 2021

Bonjour a tous
j'avais fait une fonction "DATEDIFFAMJ" il y a quelque temps pour obtenir la différence entres deux date ans mois et jour
et un demandeur a faite une demande concernant la différence entre deux dates
sauf que lui avait besoins de faire la différence de dates 1 et 2 (entre deux siècles)
et pour couronner le tout avec des dates en dessous l'année 1900
j'ai donc repris ma fonction de base et utilisé une astuce simple
si pour la date la plus ancienne c'est une année divisible par 4 ou 400 je la décale en 2020( fevrier 28/29) sinon je la décale en...

• patricktoulon
• age age entre deux sciecles datediff endessous 1900
• Réponses: 10
• Forum: Fonctions personnalisées VBA

• 
• 

 

[kiki29]

Salut, à lire : Comprendre et gérer les dates sous Excel et en VBA

 

[laurent950]

Bonsoir @patricktoulon @kiki29

Super travail Patrick.. merci
Merci @kiki29 très intéressant le cours sur la gestion des dates.

 

[BenHarber]

Bonjour @sylvanu, @vgendron, @laurent950 , @patricktoulon , @kiki29, le Forum,
Merci beaucoup pour toutes vos solutions et les connaissances apportées autour de mon pb.
Vu la qualité du travail proposé, j'en conclue que la gestion des dates et des durées a dû vous titiller sérieusement à un moment donnée !
Même si elles fonctionnent toutes, je vais plutôt retenir celle de @laurent950 qui m'épate par sa..."simplicacité" ! (= fusion de "simplicité" et "efficacité" 😉).
Encore merci pour votre réactivité ! 👋
BH