EXCEL - Vérifier une fonction sur les dates

Fermé
phanloga Messages postés 3 Date d'inscription mercredi 20 décembre 2006 Statut Membre Dernière intervention 20 décembre 2006 - 20 déc. 2006 à 17:28
G.David Messages postés 769 Date d'inscription vendredi 21 novembre 2003 Statut Membre Dernière intervention 17 janvier 2025 - 23 déc. 2006 à 09:36
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
A voir également:

1 réponse

G.David Messages postés 769 Date d'inscription vendredi 21 novembre 2003 Statut Membre Dernière intervention 17 janvier 2025 203
23 déc. 2006 à 09:36
As tu contacté Le créateur de la macro pour lui soumettre les erreur trouvées ?
je crois que cette macro est sur Excelabo (diciplus simplex)
0