Function DIFFDATES(debut, fin, Optional Renvoi As Integer = 1) As String
'Calcul de la différence entre deux dates
'Frédéric SIGONNEAU corrigé par Philippe DUVAL
Dim D1 As Date, D2 As Date, A As Integer, M As Integer, J As Long
Dim An As String, mois As String, jour As String
Dim cellText As String, blanc As String
Dim posSep1%, posSep2, J1%, J2% '8/3/2001
If TypeName(debut) <> "Range" Or TypeName(fin) <> "Range" Then
MsgBox "Références de cellules requises"
DIFFDATES = CVErr(xlErrValue)
Exit Function
End If
If IsEmpty(debut) And IsEmpty(fin) Then
DIFFDATES = ""
Exit Function
End If
If IsEmpty(debut) Or IsEmpty(fin) Then
DIFFDATES = ""
Exit Function
End If
'traite le texte des cellules pour contourner le bug
'du 29/2/1900 d'Excel, "pseudo-corrigé" en attribuant le
'même numéro de série (1) au 31/12/1899 et au 1/1/1900
On Error Resume Next
D1 = CDate(debut.Text)
'en cas d'erreur,vérifie si elle ne provient pas d'un
'format personnalisé de type "dddd dd/mm/yyyy"
If Err <> 0 Then
Err.Clear
cellText = debut.Text
If Left$(cellText, 4) = "ERR!" Then GoTo ErrDate
blanc = InStr(1, cellText, " ")
If blanc > 0 Then cellText = Right(cellText, Len(cellText) - blanc)
'nouvel essai
D1 = CDate(cellText)
'si nouvelle erreur on abandonne
If Err <> 0 Then GoTo ErrDate
End If
'même traitement pour la date de fin
D2 = CDate(fin.Text)
If Err <> 0 Then
Err.Clear
cellText = fin.Text
If Left$(cellText, 4) = "ERR!" Then GoTo ErrDate
blanc = InStr(1, cellText, " ")
If blanc > 0 Then cellText = Right(cellText, Len(cellText) - blanc)
'nouvel essai
D2 = CDate(cellText)
'si nouvelle erreur on abandonne
If Err <> 0 Then GoTo ErrDate
End If
'calcul des différences
If D1 = D2 Then
A = 0: M = 0: J = 1: GoTo MiseEnForme
End If
A = Year(D2) - Year(D1)
M = Month(D2) - Month(D1)
If M < 0 Then
A = A - 1
M = M + 12
End If
posSep1 = InStr(1, debut.Text, Application.International(xlDateSeparator))
J1 = Left(debut.Text, posSep1 - 1)
posSep2 = InStr(1, fin.Text, Application.International(xlDateSeparator))
J2 = Left(fin.Text, posSep2 - 1)
J = Day(D2) - Day(D1) + 1
If J = 31 Then
J = 0
M = M + 1
If M = 12 Then
M = 0
A = A + 1
End If
End If
If J < 0 Then
J = Day(DateSerial(Year(D1), Month(D1) + 1, 0)) - Day(D1) + Day(D2)
If M > 0 Then
M = M - 1
Else
A = A - 1
M = 11
End If
End If
MiseEnForme:
'Mise en forme
Select Case J
Case 0, 1: jour = J & " jour"
Case Else: jour = J & " jours"
End Select
mois = M & " mois "
Select Case A
Case 0, 1: An = A & " an "
Case Else: An = A & " ans "
End Select
'Résultat selon demande (paramètre optionnel)
Select Case Renvoi
Case 2: DIFFDATES = An & mois
Case 3: DIFFDATES = An
Case Else: DIFFDATES = An & mois & jour
End Select
Exit Function
ErrDate:
DIFFDATES = "#ERREUR DATE!"
End Function