Fonction qui dissèque un intervalle de temps pour des années de 365 jours

Créer une discussion
Répondre

Boostez vos compétences Excel avec notre communauté !

Rejoignez Excel Downloads, le rendez-vous des passionnés où l'entraide fait la force. Apprenez, échangez, progressez – et tout ça gratuitement ! 👉 Inscrivez-vous maintenant !

S'inscrire
Magic_Doctor

Magic_Doctor

XLDnaute Barbatruc
Supporter XLD
Bonjours,

J'ai essayé de résoudre le problème suivant : convertir en année(s) / mois COMPLET(S) / jour(s) le nombre de jours qu'il y a entre 2 dates.
Quelques conditions :
- les années ont toutes 365 jours (on ne tient donc jamais compte des années bissextiles)
- les mois sont toujours complets (fatalement les jours pourront parfois avoir plus de 31 jours suivant les dates)
- le jour de la 1ère date est toujours inclus

J'ai rédigé une fonction obèse-poussive-tordue-spaghetti, mais qui, ma foi, a l'air de marcher :
VB: 
Function DissectionTemps(dat1 As Date, dat2 As Date) As String
'Magic_Doctor
Dim nba As Integer, m1 As Integer, m2 As Byte, j1 As Byte, j2 As Byte, x As Byte
Dim mesmois As Variant, i As Byte
Dim nbtjr As Integer, nbjr As Integer
Dim nbjmr As Integer, nbjmr1 As Integer, nbjmr2 As Integer
Dim nbmr As Byte, nbmr1 As Byte, nbmr2 As Byte
Dim sentence1 As String, sentence2 As String, sentence3 As String
Dim suf1 As String, suf2 As String, slash1 As String, slash2 As String

j1 = Day(dat1): j2 = Day(dat2)
m1 = Month(dat1): m2 = Month(dat2)

If m2 < m1 Or m2 = m1 And j2 < j1 Then x = 1
nba = Year(dat2) - Year(dat1) - x 'nombre d'années entre les 2 dates
nbtjr = dat2 - DateSerial(Year(dat1) + nba, m1, j1) 'nombre total de jours restant depuis dat1 + nba jusqu'à dat2
mesmois = Array(31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31) 'mois d'une année de 365 jours

If Month(dat1) < Month(dat2) Then
    nbmr = Abs(m1 - m2 + 1) 'nombre de mois complets restant
    For i = m1 To m2 - 2
        nbjmr = nbjmr + mesmois(i) 'nombre de jours dans les mois complets restant
    Next
    nbjr = nbtjr - nbjmr + 1 'nombre de jours restant
    
    If Day(dat1) = 1 Then 'si le jour de "dat1" est un 1er du mois
        nbmr = nbmr + 1
        nbjmr = nbjmr + NbJoursDuMois(CInt(m1))
        nbjr = nbtjr - nbjmr + 1
    End If
    
    If Day(dat2) = NbJoursDuMois(m2) Then 'si le jour de "dat2" est une fin de mois
        nbmr = nbmr + 1 'nombre de mois complets restant
        nbjr = nbjr - NbJoursDuMois(m2) 'nombre de jours restant
    End If
End If

If Month(dat1) = Month(dat2) Then
    If Day(dat1) < Day(dat2) Then
        nbmr = IIf(Day(dat1) = 1 And Day(dat2) = NbJoursDuMois(CInt(m1)), 1, 0) 'nombre de mois complets restant
        nbjr = IIf(Day(dat1) = 1 And Day(dat2) = NbJoursDuMois(CInt(m1)), 0, nbtjr) 'nombre de jours restant
    ElseIf Day(dat1) = Day(dat2) Then
        nbjr = 0
    Else
        For i = m1 To 11
            nbjmr1 = nbjmr1 + mesmois(i) '1ère tranche du nombre de jours dans les mois complets restant
        Next
    
        For i = 0 To m2 - 2
            nbjmr2 = nbjmr2 + mesmois(i) '2ème tranche du nombre de jours dans les mois complets restant
        Next
        nbmr = 11 'nombre de mois complets restant
        nbjmr = nbjmr1 + nbjmr2 'nombre de jours dans les mois complets restant
        nbjr = nbtjr - nbjmr 'nombre de jours restant
    End If
End If

If Month(dat1) > Month(dat2) Then
    For i = m1 To 11
        nbjmr1 = nbjmr1 + mesmois(i) '1ère tranche du nombre de jours dans les mois complets restant
    Next
    nbmr1 = 12 - m1
    
    If Day(dat1) = 1 Then 'si le jour de "dat1" est un 1er du mois
        nbmr1 = nbmr1 + 1
        nbjmr1 = nbjmr1 + NbJoursDuMois(CInt(m1))
    End If
    
    If Month(dat2) = 1 Then 'le mois de "dat2" est janvier
        If Day(dat1) = 1 Then 'si le jour de "dat1" est un 1er du mois
            nbmr = 13 - Month(dat1)
            nbjr = Day(dat2)
        Else
            nbmr = nbmr1
            nbjr = nbtjr - nbjmr1 + 1
        End If
        GoTo after
    End If
    
    For i = 0 To m2 - 2
        nbjmr2 = nbjmr2 + mesmois(i) '2ème tranche du nombre de jours dans les mois complets restant
    Next
    nbmr2 = Month(dat2) - 1 '2ème tranche du nombre de jours dans les mois complets restant
    nbmr = nbmr1 + nbmr2 'nombre de mois complets restant
    nbjmr = nbjmr1 + nbjmr2 'nombre de jours dans les mois complets restant
    nbjr = nbtjr - nbjmr 'nombre de jours restant
after:
    If Day(dat2) = NbJoursDuMois(m2) Then 'si le jour de "dat2" est une fin de mois
        nbmr = nbmr + 1 'nombre de mois complets restant
        nbjr = nbjr - NbJoursDuMois(m2) 'nombre de jours restant
    End If
    If Day(dat1) = 1 And Day(dat2) = NbJoursDuMois(m2) Then 'si le jour de "dat1" est le 1er d'un mois et le jour de "dat2" est une fin de mois
        If nbmr = 12 Then nbmr = 11: nbjr = NbJoursDuMois(m2)
    End If
End If
    
'*************************** Éléments de la chaîne ***************************
    suf1 = IIf(nba > 1, "s", "")
    suf2 = IIf(nbjr > 1, "s", "")
    sentence1 = IIf(nba = 0, "", nba & " an" & suf1)
    sentence2 = IIf(nbmr = 0, "", nbmr & " mois")
    sentence3 = IIf(nbjr = 0, "", nbjr & " jour" & suf2)
    slash1 = IIf(sentence1 = "" Or sentence2 = "", "", " / ")
    slash2 = IIf(sentence1 = "" And sentence2 = "" Or sentence2 = "" And sentence3 = "" Or sentence2 <> "" And sentence3 = "", "", " / ")
'*****************************************************************************
DissectionTemps = sentence1 & slash1 & sentence2 & slash2 & sentence3
End Function
'-----------------------------------------------------------------------------------------------
Function NbJoursDuMois(m As Byte, Optional année As Integer = 0) As Byte
'Renvoie le nombre de jours d'un mois en fonction de son Nº
'- m : un Nº de mois (janvier --> 1 ... décembre --> 12)
'- année : si omis, ne tiendra pas compte des années bissextiles (février -2- aura toujours 28 jours)
'Magic_Doctor
    Dim mesmois As Variant, x As Byte, nbjoursmois As Byte
    
    x = IIf(année = 0, 28, IIf(LeapYear(année), 29, 28))
    mesmois = Array(31, x, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31)
    
    NbJoursDuMois = mesmois(m - 1)
End Function
'-----------------------------------------------------------------------------------------------
Function LeapYear(a%) As Boolean
'Vérifie si une année est bissextile ou pas (tient compte des années théoriquement bissextiles et qui ne le sont en fait pas, comme 1800/1900/2100...)
'- a : une année quelconque
'ROGER2327
    LeapYear = ((a Mod 4) = 0) * (1 + ((a Mod 100) = 0) * (1 + (((a \ 100) Mod 4) = 0)))
End Function
Peut-on "dégraisser ce mammouth" ?
 

Pièces jointes

Dernière édition:
Trier par date Trier par votes
Re : Fonction qui dissèque un intervalle de temps pour des années de 365 jours

Bonsour®
espérant avoir compris ... qu'il ne s'agit pas de la classique décomposition age en année mois jours 😡
mais combien :
d'années complètes
de mois complets
de jours appartenant à des mois incomplets
VB: 
Function Magic_DD(DateDeb As Date, dateFin As Date) As String
Dim MoisEnt As Integer
    Magic_DD = Format(dateFin - DateDeb, "yyyy") - 1900 & " an(s)"
    '-------------------------------------------nbr de mois complets
    MoisEnt = DateDiff("m", DateSerial(Year(DateDeb), Month(DateDeb) + 1, 1), DateSerial(Year(dateFin), Month(dateFin), 1) - 1)
    Magic_DD = Magic_DD & " / " & MoisEnt & " mois"
    ' ------------------------------------------nbr de jours appartenant à des mois incomplet
    Magic_DD = Magic_DD & " / " & (dateFin - DateDeb) - (DateSerial(Year(dateFin), Month(dateFin), 1) - DateSerial(Year(DateDeb), Month(DateDeb) + 1, 0)) & " jour(s)"
    ' ------------------------------------------nbr total de jours
    'Magic_DD = Magic_DD & " / " & dateFin - DateDeb & " jour(s)"
End Function

on utilise ici la fonction VBA DatediFF qui n'a aucun rapport avec la fonction cachée de feuille de calcul DATEDIF
 
Dernière édition:
Vote positif 0 Vote négatif
Re : Fonction qui dissèque un intervalle de temps pour des années de 365 jours

Re
Avec un fonction trouver sur la toile.

PHP: 
Option Explicit

Private Function Calc_Diff(ByVal maDate1 As Date, _
                           ByVal maDate2 As Date) As String

    ' Renvoie une chaine comme "2 ans 3 mois 18 jours ..."
    
    Dim lAn As Long, lMois As Long, lJour As Long
    Dim lHeure As Long, lMinute As Long, lSeconde As Long
    Dim DateTemp As Date, Temp As String
    
    ' Remet les dates dans l'ordre si besoin : Date1 avant Date2
    If maDate1 > maDate2 Then
        DateTemp = maDate1
        maDate1 = maDate2
        maDate2 = DateTemp
    End If
    
    ' L'inconvénient de DateDiff, c'est qu'il arrondi le résultat :
    ' Si on cherche le nombre d'années entre deux dates alors que _
      ces dates ne sont séparées que de 11 mois, il renverra 1 an.
    ' Pour éviter cela, après avoir récupéré le nombre, on teste _
      si la (Date1 + Nombre) > Date2, c'est qu'il y a eu un arrondi
    ' Dans ce cas, on enlève 1 et le tour est joué.
    
    '--- Nombre d'années
    lAn = DateDiff("yyyy", maDate1, maDate2)
    If DateAdd("yyyy", lAn, maDate1) > maDate2 Then lAn = lAn - 1
    ' Décale la date d'autant
    maDate1 = DateAdd("yyyy", lAn, maDate1)
    
    '--- Nombre de mois
    lMois = DateDiff("m", maDate1, maDate2)
    If DateAdd("m", lMois, maDate1) > maDate2 Then lMois = lMois - 1
    ' Décale la date d'autant
    maDate1 = DateAdd("m", lMois, maDate1)
    
    '--- Nombre de jours
    lJour = DateDiff("d", maDate1, maDate2)
    If DateAdd("d", lJour, maDate1) > maDate2 Then lJour = lJour - 1
    ' Décale la date d'autant
    maDate1 = DateAdd("d", lJour, maDate1)
    
    '--- Nombre d'heures
    lHeure = DateDiff("h", maDate1, maDate2)
    If DateAdd("h", lHeure, maDate1) > maDate2 Then lHeure = lHeure - 1
    ' Décale la date d'autant
    maDate1 = DateAdd("h", lHeure, maDate1)
    
    '--- Nombre de minutes
    lMinute = DateDiff("n", maDate1, maDate2)
    If DateAdd("n", lMinute, maDate1) > maDate2 Then lMinute = lMinute - 1
    ' Décale la date d'autant
    maDate1 = DateAdd("n", lMinute, maDate1)
    
    '--- Nombre de secondes
    lSeconde = DateDiff("s", maDate1, maDate2)

'Debug.Print lAn, lMois, lJour, lHeure, lMinute, lSeconde
    
    ' Mise en forme de la chaîne à renvoyer :
    Temp = IIf(lAn > 0, CStr(lAn) & " an(s) ", "")
    Temp = Temp & IIf(lMois > 0, CStr(lMois) & " mois ", "")
    Temp = Temp & IIf(lJour > 0, CStr(lJour) & " jours ", "")
    Temp = Temp & IIf(lHeure > 0, CStr(lHeure) & " heure(s) ", "")
    Temp = Temp & IIf(lMinute > 0, CStr(lMinute) & "minute (s) ", "")
    Temp = Temp & IIf(lSeconde > 0, CStr(lSeconde) & "seconde (s)", "")
    Calc_Diff = Temp
    
End Function

Function EcartDates(DateOuverture As Date, DateReception As Date)
EcartDates = DateDiff("yyyy", DateOuverture, DateReception, vbMonday, vbFirstJan1)
'EcartMois = DateDiff("m", DateOuverture, DateReception, vbMonday, vbFirstJan1)
End Function
 
Vote positif 0 Vote négatif
Re : Fonction qui dissèque un intervalle de temps pour des années de 365 jours

Bonsoir Regueiro,

Reconozco que el tema es medio jodido...
J'ai comparé mes résultats avec les vôtres. Ça coïncide rarement.
Fatalement, en faisant encore des essais de dates, j'ai découvert de temps en temps des erreurs (d'un jour) avec ma fonction. J'en ai profité pour modifier celle-ci en conséquence :
VB: 
Function DissectionTemps(dat1 As Date, dat2 As Date) As String
'Magic_Doctor
Dim dat1bis As Date, nba As Integer, m1 As Integer, m2 As Byte, j1 As Byte, j2 As Byte, x As Byte
Dim mesmois As Variant, i As Byte
Dim nbtjr As Integer, nbjr As Integer
Dim nbjmr As Integer, nbjmr1 As Integer, nbjmr2 As Integer
Dim nbmr As Byte, nbmr1 As Byte, nbmr2 As Byte
Dim sentence1 As String, sentence2 As String, sentence3 As String
Dim suf1 As String, suf2 As String, slash1 As String, slash2 As String

j1 = Day(dat1): j2 = Day(dat2)
m1 = Month(dat1): m2 = Month(dat2)

If m2 < m1 Or m2 = m1 And j2 < j1 Then x = 1
nba = Year(dat2) - Year(dat1) - x 'nombre d'années entre "dat1" et "dat2"
dat1bis = DateSerial(Year(dat1) + nba, m1, j1) '"dat1" + "nba"

x = Nb29Fev(dat1bis, dat2) 'on identifie un éventuel 29 février entre "dat1bis" et "dat2"

nbtjr = dat2 - dat1bis - x 'nombre total de jours restant (sans "29 février" s'il y en avait un -années de 365 jours !-) depuis "dat1bis" jusqu'à "dat2"
mesmois = Array(31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31) 'mois d'une année de 365 jours

If m1 < m2 Then
    nbmr = Abs(m1 - m2 + 1) 'nombre de mois complets restant
    For i = m1 To m2 - 2
        nbjmr = nbjmr + mesmois(i) 'nombre de jours dans les mois complets restant
    Next
    nbjr = nbtjr - nbjmr + 1 'nombre de jours restant
    
    If j1 = 1 Then 'si le jour de "dat1" est un 1er du mois
        nbmr = nbmr + 1
        nbjmr = nbjmr + NbJoursDuMois(CInt(m1))
        nbjr = nbtjr - nbjmr + 1
    End If
    
    If j2 = NbJoursDuMois(m2) Then 'si le jour de "dat2" est une fin de mois
        nbmr = nbmr + 1 'nombre de mois complets restant
        nbjr = nbjr - NbJoursDuMois(m2) 'nombre de jours restant
    End If
End If

If m1 = m2 Then
    If j1 < j2 Then
        nbmr = IIf(j1 = 1 And j2 = NbJoursDuMois(CInt(m1)), 1, 0) 'nombre de mois complets restant
        nbjr = IIf(j1 = 1 And j2 = NbJoursDuMois(CInt(m1)), 0, nbtjr + 1) 'nombre de jours restant
    ElseIf j1 = j2 Then
        nbjr = 0
    Else
        For i = m1 To 11
            nbjmr1 = nbjmr1 + mesmois(i) '1ère tranche du nombre de jours dans les mois complets restant
        Next
    
        For i = 0 To m2 - 2
            nbjmr2 = nbjmr2 + mesmois(i) '2ème tranche du nombre de jours dans les mois complets restant
        Next
        nbmr = 11 'nombre de mois complets restant
        nbjmr = nbjmr1 + nbjmr2 'nombre de jours dans les mois complets restant
        nbjr = nbtjr - nbjmr 'nombre de jours restant
    End If
End If

If m1 > m2 Then
    For i = m1 To 11
        nbjmr1 = nbjmr1 + mesmois(i) '1ère tranche du nombre de jours dans les mois complets restant
    Next
    nbmr1 = 12 - m1
    
    If j1 = 1 Then 'si le jour de "dat1" est un 1er du mois
        nbmr1 = nbmr1 + 1
        nbjmr1 = nbjmr1 + NbJoursDuMois(CInt(m1))
    End If
    
    If m2 = 1 Then 'le mois de "dat2" est janvier
        If j1 = 1 Then 'si le jour de "dat1" est un 1er du mois
            nbmr = 13 - m1: nbjr = j2
        Else
            nbmr = nbmr1: nbjr = nbtjr - nbjmr1 + 1
        End If
        GoTo after
    End If
    
    For i = 0 To m2 - 2
        nbjmr2 = nbjmr2 + mesmois(i) '2ème tranche du nombre de jours dans les mois complets restant
    Next
    nbmr2 = m2 - 1 '2ème tranche du nombre de jours dans les mois complets restant
    nbmr = nbmr1 + nbmr2 'nombre de mois complets restant
    nbjmr = nbjmr1 + nbjmr2 'nombre de jours dans les mois complets restant
    nbjr = nbtjr - nbjmr + 1 'nombre de jours restant
after:
    If j2 = NbJoursDuMois(m2) Then 'si le jour de "dat2" est une fin de mois
        nbmr = nbmr + 1 'nombre de mois complets restant
        nbjr = nbjr - NbJoursDuMois(m2) 'nombre de jours restant
    End If
    If j1 = 1 And j2 = NbJoursDuMois(m2) Then 'si le jour de "dat1" est le 1er d'un mois et le jour de "dat2" est une fin de mois
        If nbmr = 12 Then nbmr = 11: nbjr = NbJoursDuMois(m2)
    End If
End If
    
'*************************** Éléments de la chaîne ***************************
    suf1 = IIf(nba > 1, "s", "")
    suf2 = IIf(nbjr > 1, "s", "")
    sentence1 = IIf(nba = 0, "", nba & " an" & suf1)
    sentence2 = IIf(nbmr = 0, "", nbmr & " mois")
    sentence3 = IIf(nbjr = 0, "", nbjr & " jour" & suf2)
    slash1 = IIf(sentence1 = "" Or sentence2 = "", "", " / ")
    slash2 = IIf(sentence1 = "" And sentence2 = "" Or sentence2 = "" And sentence3 = "" Or sentence2 <> "" And sentence3 = "", "", " / ")
'******************************************************************************
DissectionTemps = sentence1 & slash1 & sentence2 & slash2 & sentence3
End Function

'---------------------------------------------------------------------------
Function NbJoursDuMois(m As Byte, Optional année As Integer = 0) As Byte
'Renvoie le nombre de jours d'un mois en fonction de son Nº
'- m : un Nº de mois (janvier --> 1 ... décembre --> 12)
'- année : si omis, ne tiendra pas compte des années bissextiles (février -2- aura toujours 28 jours)
'Magic_Doctor
    Dim mesmois As Variant, x As Byte, nbjoursmois As Byte
    
    x = IIf(année = 0, 28, IIf(LeapYear(année), 29, 28))
    mesmois = Array(31, x, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31)
    
    NbJoursDuMois = mesmois(m - 1)
End Function

'---------------------------------------------------------------------------
Function LeapYear(a%) As Boolean
'Vérifie si une année est bissextile ou pas (tient compte des années théoriquement bissextiles et qui ne le sont en fait pas, comme 1800/1900/2100...)
'- a : une année quelconque
'ROGER2327
    LeapYear = ((a Mod 4) = 0) * (1 + ((a Mod 100) = 0) * (1 + (((a \ 100) Mod 4) = 0)))
End Function

'---------------------------------------------------------------------------
Function Nb29Fev(d1 As Date, d2 As Date) As Byte
'Renvoie le nombre de "29 février" entre 2 dates
'job75
    Nb29Fev = CDate("1/" & Year(d2) + 1) - CDate("1/" & Year(d1)) - 365 * (1 + Year(d2) - Year(d1))
    If IsDate("29/2/" & Year(d1)) Then If d1 > CDate("29/2/" & Year(d1)) Then Nb29Fev = Nb29Fev - 1
    If IsDate("29/2/" & Year(d2)) Then If d2 < CDate("29/2/" & Year(d2)) Then Nb29Fev = Nb29Fev - 1
End Function
Mais, cela ne m'étonnerait pas qu'il persiste d'autres erreurs...

Je n'ai pas encore eu le temps de tester la fonction que vous m'avez adressée.

Muchas gracias por el interés.
 

Pièces jointes

Dernière édition:
Vote positif 0 Vote négatif
Re : Fonction qui dissèque un intervalle de temps pour des années de 365 jours

Bonsour®

en pièce jointe: un petit point sur les propositions .
à l'évidence aucune ne correspond à ton souhait...
cependant en toute logique il y a quelques incohérences :
tu cumules le nombre de jours. pour finir le mois de début au nombre de jours appartenant au mois de fin

pourquoi alors ne pas utiliser la même logique pour les mois ?
nombre de mois entier pour finir l'année de début + nombre de mois complets écoulés pour l'année de fin
et compter alors le nombre d'années complètes (Janv-Déc) au lieu du nombre de fois 12 mois complets

ex :26/07/1934 au 14/11/2013
ta solution : 79 ans / 3 mois / 20 jours

en toute logique :
78 ans / 5+10 mois / 5+14 jours

MichD (sur MPFE) faisait justement remarquer que cette notion de mois est sujette à caution sachant que ceux-ci n'ont pas le même nombre de jours, et qu'il serait plus juste de s'en tenir au nombre d'anniversaires + nombre de jours depuis le précédent anniversaire
=ENT((B5-A5)/365)& " an(s) " &(B5-DATE(ANNEE(B5)-(TEXTE(B5;"mmjj")<TEXTE(A5;"mmjj"));MOIS(A5);JOUR(A5)))&" jour(s)"
 

Pièces jointes

Vote positif 0 Vote négatif
Re : Fonction qui dissèque un intervalle de temps pour des années de 365 jours

Bonsoir à Tous.
Buenas noche

Voici une plus simple qui fonctionne chez moi

Function Age(Date1 As Date, Date2 As Date) As String
'Calcul l'âge d'un personne

Dim Y As Integer
Dim M As Integer
Dim D As Integer
Dim Temp1 As 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), 0)) + D
End If
Age = Y & " An(s) / " & M & " Mois / " & D & " Jours"
End Function
Cliquez pour agrandir...

Bonne Nuit
A+
 
Vote positif 0 Vote négatif
Re : Fonction qui dissèque un intervalle de temps pour des années de 365 jours

Bonjour à tous,

J'avais planché de mon coté avant de voir les 2 derniers posts. Les résultats sont presques toujours semblables avec la dernière proposition de Regueiro.

Un contre exemple :

30/12/1900 - 7/3/2019
Reg.= 118 An(s) / 2 Mois / 5 Jours
J'obtiens 118 An(s) / 2 Mois / 7 Jours.

J'ajoute 118 ans et 2 mois, j'obtiens le 30 février 2019 qui n'existe pas, je me calque sur le dernier existant c.a.d le 28/2/2019.
C'est le choix qui me semble le plus logique mais c'est un choix personnel. On peut choisir la logique qui entame le mois suivant.

Un autre :

31/10/2011 - 3/10/2029
Reg.= 17 An(s) / 11 Mois / 2 Jours (31/9/2029 ramené au 1/10/2029)
J'obtiens 17 An(s) / 11 Mois / 3 Jours (31/9/2029 ramené au 30/9/2029)

Un dernier :
29/2/2012 - 1/3/2013
Reg.= 1 An(s) / 0 Mois / 0 Jours
J'obtiens 1 An(s) / 0 Mois / 1 Jours

Cordialement

KD

VB: 
Option Explicit
Function DateDifString(ByVal Dt1 As Date, Dt2 As Date) As String
    Dim Dt3 As Date, c&, sy$, sj$, y1&, y2&, m1&, m2, d1&, d2&, d3&, m3&, y3&
    If Dt2 < Dt1 Then Dt3 = Dt1: Dt1 = Dt2: Dt2 = Dt3
    y1 = Year(Dt1): m1 = Month(Dt1): d1 = Day(Dt1): y2 = Year(Dt2): m2 = Month(Dt2): d2 = Day(Dt2)
    Do: c = c + 1: Loop Until IsPost(y1 + c, m1, d1, y2, m2, d2)
    y3 = c - 1: y1 = y2: c = 0: m1 = m1 + 12 * (m1 > m2) - 12 * (m1 = m2) * (d1 > d2)
    Do: c = c + 1: Loop Until IsPost(y1, m1 + c, d1, y2, m2, d2)
    m3 = c - 1: d3 = d2 - d1
    If d3 < 0 Then
        c = 28
        If m2 = 3 Then c = c - (y2 Mod 4 = 0 And ((y2 Mod 400 = 0) Or (y2 Mod 100 > 0))) Else _
            c = c + 2 - (Not Abs(m2 - 6) = 1 And Not Abs(m2 - 11) = 1)
        y1 = c - d1: d3 = d2 - y1 * (y1 > 0)
    End If
    If y3 > 1 Then sy = "s"
    If d3 > 1 Then sj = "s"
    DateDifString = y3 & " an" & sy & " / " & m3 & " mois / " & d3 & " jour" & sj
End Function
Function IsPost(ByVal y1&, ByVal m1&, ByVal d1&, ByVal y2&, ByVal m2&, ByVal d2&) As Boolean
    If y1 > y2 Then
        IsPost = True
    ElseIf y1 = y2 Then
        If m1 > m2 Then
            IsPost = True
        ElseIf m1 = m2 Then
            IsPost = (d1 > d2)
        End If
    End If
End Function
 

Pièces jointes

Vote positif 0 Vote négatif
Re : Fonction qui dissèque un intervalle de temps pour des années de 365 jours

Bonsoir à tous,

Je tiens tout d'abord à préciser que cette fonction ne sert pas vraiment à grand-chose, c'est avant tout un exercice de l'esprit.
L'idée m'est venue lors de la création d'un plan d'amortissement linéaire. Je connaissais, mais vraiment de très très loin...
En fouinant sur le net, j'ai fini par en comprendre la logique avant de la retranscrire sur un tableur. Entre autres choses, j'apprends que l'on peut sortir prématurément son immobilisation, moyennant (bien évidemment...) une pénalité fiscale. Je voulais tout simplement savoir, au cas où l'on décide d'arrêter l'amortissement avant son terme, pendant combien de temps exactement l'on avait amorti l'immobilisation. Ça c'est pas bien compliqué, on obtient un nombre de jours que l'on converti ensuite, pour que ce soit plus clair, en nombre d'années + jours. On pourrait évidemment s'en tenir à ce résultat ; c'est du reste, je pense, le dernier commentaire de Modeste geedee dans son dernier post (MichD...). Mais obtenir, par exemple, 3 ans et 256 jours, ce n'est pas forcément spontanément très clair. C'est pourquoi je me suis dit que ce serait pas mal de convertir les 256 jours en quelque chose de plus parlant, c'est-à-dire en mois et en jours.
Pour les années dites comptables de 360 jours (12 mois de 30 jours) c'est pas bien compliqué, mais pour les années fiscales de 365 jours c'est une autre affaire, si bien sûr l'on veut être rigoureux.
La 1ère date est donc la date de mise en service de l'actif (début de l'amortissement) et la 2ème date celle de la sortie anticipée de l'amortissement.
Pour résoudre le problème, je me suis dit que d'abord il fallait reporter la date de mise en service de l'actif à cette même date + le nombre d'années durant lesquelles on a amorti . Là aussi ce n'est pas bien compliqué. restent les fameux jours depuis cette dernière date jusqu'à la date de sortie anticipée. On parcourt tous ces jours en répertoriant ceux qui "remplissent" des mois (qui malheureusement ne comportent pas tous le même nombre de jours...), on fait le décompte de tous ces mois et de l'ensemble de leurs jours. Le nombre de jours restant sera alors 256 - le nombre de jours des mois complets. Ce résultat est très facile à vérifier : c'est le nombre de jours depuis le premier jour (INCLUS) de la 1ère date jusqu'à la fin du mois (INCLUS) de celle-ci + le nombre de jours de la 2ème date. Pourquoi le 1er jour est-il inclu ? Tout simplement parce que la mise en service de l'actif se fait le jour même de sa mise en service et non pas le lendemain (erreur de "cancre" que j'ai pu constater dans maint exemple comptable sur le net). Du reste, je ne veux pas trop m'avancer, mais il me semble avoir lu quelque part que la fonction que propose Excel à ce sujet commet préciément cette erreur. Bon, c'est pas bien grave, il ne s'agit après tout que d'un seul jour et l'essentiel est que l'immobilisation soit totalement amortie d'une manière cohérente.

Je n'ai pas eu le temps d'essayer vos solutions. Mañana, porque ahora no puedo más y me voy a noni noni.

Un grand merci à tous y muy buenas noches.
 
Dernière édition:
Vote positif 0 Vote négatif
Re : Fonction qui dissèque un intervalle de temps pour des années de 365 jours

Bonjour Roger, le forum,

Je n'ai pas pu résister à regarder votre post.
Votre tableau est "cruel", car effectivement, dans ma logique de départ où le décompte se fait suivant [début ; fin], il y a, pour l'exemple que vous donnez, un écart de 1 jour (en moins chez moi) et c'est votre résultat qui est le bon. J'ai réglé le problème à la hussarde en comprenant que cet écart de un jour n'apparaissait que si l'année de la 1ère date est bissextile et que le mois est février.
Maintenant, je l'espère, la fonction devrait marcher quelles que soient les dates. Mais... sait-on jamais...
VB: 
Function DissectionTemps(dat1 As Date, dat2 As Date) As String
'Magic_Doctor
Dim dat1bis As Date, nba As Integer, m1 As Integer, m2 As Byte, j1 As Byte, j2 As Byte, x As Byte
Dim mesmois As Variant, i As Byte
Dim nbtjr As Integer, nbjr As Integer
Dim nbjmr As Integer, nbjmr1 As Integer, nbjmr2 As Integer
Dim nbmr As Byte, nbmr1 As Byte, nbmr2 As Byte
Dim sentence1 As String, sentence2 As String, sentence3 As String
Dim suf1 As String, suf2 As String, slash1 As String, slash2 As String

j1 = Day(dat1): j2 = Day(dat2)
m1 = Month(dat1): m2 = Month(dat2)
If m2 < m1 Or m2 = m1 And j2 < j1 Then x = 1
nba = Year(dat2) - Year(dat1) - x 'nombre d'années entre "dat1" et "dat2"
dat1bis = DateSerial(Year(dat1) + nba, m1, j1) '"dat1" + "nba"
x = Nb29Fev(dat1bis, dat2) 'on identifie un éventuel 29 février entre "dat1bis" et "dat2"
nbtjr = dat2 - dat1bis - x 'nombre total de jours restant (sans "29 février" s'il y en avait un -années de 365 jours !-) depuis "dat1bis" jusqu'à "dat2"
mesmois = Array(31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31) 'mois d'une année de 365 jours

If m1 < m2 Then
    nbmr = Abs(m1 - m2 + 1) 'nombre de mois complets restant
    For i = m1 To m2 - 2
        nbjmr = nbjmr + mesmois(i) 'nombre de jours dans les mois complets restant
    Next
    
    x = IIf(LeapYear(Year(dat1)) And m1 = 2, 1, 0)
    nbjr = nbtjr - nbjmr + 1 + x 'nombre de jours restant
    
    If j1 = 1 Then 'si le jour de "dat1" est un 1er du mois
        nbmr = nbmr + 1
        nbjmr = nbjmr + NbJoursDuMois(CInt(m1))
        nbjr = nbtjr - nbjmr + 1
    End If
    
    If j2 = NbJoursDuMois(m2) Then 'si le jour de "dat2" est une fin de mois
        nbmr = nbmr + 1 'nombre de mois complets restant
        nbjr = nbjr - NbJoursDuMois(m2) 'nombre de jours restant
    End If
End If

If m1 = m2 Then
    If j1 < j2 Then
        nbmr = IIf(j1 = 1 And j2 = NbJoursDuMois(CInt(m1)), 1, 0) 'nombre de mois complets restant
        nbjr = IIf(j1 = 1 And j2 = NbJoursDuMois(CInt(m1)), 0, nbtjr + 1) 'nombre de jours restant
    ElseIf j1 = j2 Then
        nbjr = 0
    Else
        For i = m1 To 11
            nbjmr1 = nbjmr1 + mesmois(i) '1ère tranche du nombre de jours dans les mois complets restant
        Next
    
        For i = 0 To m2 - 2
            nbjmr2 = nbjmr2 + mesmois(i) '2ème tranche du nombre de jours dans les mois complets restant
        Next
        nbmr = 11 'nombre de mois complets restant
        nbjmr = nbjmr1 + nbjmr2 'nombre de jours dans les mois complets restant
        nbjr = nbtjr - nbjmr 'nombre de jours restant
    End If
End If

If m1 > m2 Then
    For i = m1 To 11
        nbjmr1 = nbjmr1 + mesmois(i) '1ère tranche du nombre de jours dans les mois complets restant
    Next
    nbmr1 = 12 - m1
    
    If j1 = 1 Then 'si le jour de "dat1" est un 1er du mois
        nbmr1 = nbmr1 + 1
        nbjmr1 = nbjmr1 + NbJoursDuMois(CInt(m1))
    End If
    
    If m2 = 1 Then 'le mois de "dat2" est janvier
        If j1 = 1 Then 'si le jour de "dat1" est un 1er du mois
            nbmr = 13 - m1: nbjr = j2
        Else
            nbmr = nbmr1: nbjr = nbtjr - nbjmr1 + 1
        End If
        GoTo after
    End If
    
    For i = 0 To m2 - 2
        nbjmr2 = nbjmr2 + mesmois(i) '2ème tranche du nombre de jours dans les mois complets restant
    Next
    nbmr2 = m2 - 1 '2ème tranche du nombre de jours dans les mois complets restant
    nbmr = nbmr1 + nbmr2 'nombre de mois complets restant
    nbjmr = nbjmr1 + nbjmr2 'nombre de jours dans les mois complets restant
    nbjr = nbtjr - nbjmr + 1 'nombre de jours restant
after:
    If j2 = NbJoursDuMois(m2) Then 'si le jour de "dat2" est une fin de mois
        nbmr = nbmr + 1 'nombre de mois complets restant
        nbjr = nbjr - NbJoursDuMois(m2) 'nombre de jours restant
    End If
    If j1 = 1 And j2 = NbJoursDuMois(m2) Then 'si le jour de "dat1" est le 1er d'un mois et le jour de "dat2" est une fin de mois
        If nbmr = 12 Then nbmr = 11: nbjr = NbJoursDuMois(m2)
    End If
End If
    
'*************************** Éléments de la chaîne ***************************
    suf1 = IIf(nba > 1, "s", "")
    suf2 = IIf(nbjr > 1, "s", "")
    sentence1 = IIf(nba = 0, "", nba & " an" & suf1)
    sentence2 = IIf(nbmr = 0, "", nbmr & " mois")
    sentence3 = IIf(nbjr = 0, "", nbjr & " jour" & suf2)
    slash1 = IIf(sentence1 = "" Or sentence2 = "", "", " / ")
    slash2 = IIf(sentence1 = "" And sentence2 = "" Or sentence2 = "" And sentence3 = "" Or sentence2 <> "" And sentence3 = "", "", " / ")
'*****************************************************************************
DissectionTemps = sentence1 & slash1 & sentence2 & slash2 & sentence3
End Function
'------------------------------------------------------------------
Function NbJoursDuMois(m As Byte, Optional année As Integer = 0) As Byte
'Renvoie le nombre de jours d'un mois en fonction de son Nº
'- m : un Nº de mois (janvier --> 1 ... décembre --> 12)
'- année : si omis, ne tiendra pas compte des années bissextiles (février -2- aura toujours 28 jours)
'Magic_Doctor
    Dim mesmois As Variant, x As Byte, nbjoursmois As Byte
    
    x = IIf(année = 0, 28, IIf(LeapYear(année), 29, 28))
    mesmois = Array(31, x, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31)
    
    NbJoursDuMois = mesmois(m - 1)
End Function
'------------------------------------------------------------------
Function LeapYear(a%) As Boolean
'Vérifie si une année est bissextile ou pas (tient compte des années théoriquement bissextiles et qui ne le sont en fait pas, comme 1800/1900/2100...)
'- a : une année quelconque
'ROGER2327
    LeapYear = ((a Mod 4) = 0) * (1 + ((a Mod 100) = 0) * (1 + (((a \ 100) Mod 4) = 0)))
End Function
'------------------------------------------------------------------
Function Nb29Fev(d1 As Date, d2 As Date) As Byte
'Renvoie le nombre de "29 février" entre 2 dates
'job75
    Nb29Fev = CDate("1/" & Year(d2) + 1) - CDate("1/" & Year(d1)) - 365 * (1 + Year(d2) - Year(d1))
    If IsDate("29/2/" & Year(d1)) Then If d1 > CDate("29/2/" & Year(d1)) Then Nb29Fev = Nb29Fev - 1
    If IsDate("29/2/" & Year(d2)) Then If d2 < CDate("29/2/" & Year(d2)) Then Nb29Fev = Nb29Fev - 1
End Function
Bonne journée.
 

Pièces jointes

Dernière édition:
Vote positif 0 Vote négatif
Re : Fonction qui dissèque un intervalle de temps pour des années de 365 jours

Bonjour MJ13,

Nos posts ont dû se croiser. Je venais de me rendre compte que lors de la dernière modification j'avais commis une bourde. Je l'ai corrigée (voir mon dernier post #13 et utiliser le classeur joint), et maintenant, pour les dates que vous me donnez, on obtient bien 1 an.
Roger, si vous me lisez, il peut y avoir discordance entre vos résultats et les miens. Par exemple, pour :
02/01/2000 -- 13/01/2007
M_D : 7 ans / 12 jours
ROGER : 6 ans / 11 mois / 42 jours
 
Vote positif 0 Vote négatif
Rejoins nos membres "Supporter XLD" et booste ton expérience Excel !
- Navigue sans publicité
- Accède à Cléa, notre assistante IA experte Excel... et pas que...
- Profite de fonctionnalités exclusives
Ton soutien permet à Excel Downloads de rester 100% gratuit et de continuer à rassembler les passionnés d'Excel.
Je deviens Supporter XLD

Discussions similaires

Jouxte
  • Question Question
XL 2013 VBA insérer des retours à la ligne dans un résultat
Réponses
1
Affichages
748
sylvanu
sylvanu
Retour