EXCEL - Vérifier une fonction sur les dates
phanloga
Messages postés
3
Statut
Membre
-
G.David Messages postés 790 Statut Membre -
G.David Messages postés 790 Statut Membre -
Bonjour,
Voici, ci dessous, une fonction pour compter le nombre d'années, de mois et de jours entre deux dates.
Quelqu'un peut-il vérifier ce code et me dire pourquoi il y a des erreurs dans le nombre de jours ?
Merci d'avance.
Function DIFFDATES(Debut, Fin, Optional Renvoi As Integer = 1) As String
'Frédéric Sigonneau
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 = "#MANQUE DATE!"
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 = 0: 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 = J2 - J1
If J < 0 Then
J = Day(DateSerial(Year(D1), Month(D1) + 1, 0)) - J1 + J2
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
Voici, ci dessous, une fonction pour compter le nombre d'années, de mois et de jours entre deux dates.
Quelqu'un peut-il vérifier ce code et me dire pourquoi il y a des erreurs dans le nombre de jours ?
Merci d'avance.
Function DIFFDATES(Debut, Fin, Optional Renvoi As Integer = 1) As String
'Frédéric Sigonneau
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 = "#MANQUE DATE!"
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 = 0: 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 = J2 - J1
If J < 0 Then
J = Day(DateSerial(Year(D1), Month(D1) + 1, 0)) - J1 + J2
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
A voir également:
- EXCEL - Vérifier une fonction sur les dates
- Nombre de jours entre deux dates excel - Guide
- Fonction si et excel - Guide
- Liste déroulante excel - Guide
- Déplacer une colonne excel - Guide
- Word et excel gratuit - Guide