[VBA]Calculé age d 'une personne au jour près

O

oxydedefer

XLDnaute Nouveau
Bonjour , je souhaite avoir l'age en année d une personne , cette age dois changé si c'est le jour de son anniversaire ,et dois prendre en compte les année bissextile . J'ai déjà trouver une bonne formule , le soucis c'est lorsque je l'incorpore à mon programme vba il me met un age de :(
Code: 
ActiveCell.FormulaR1C1 = "=DATEDIF(RC[-1],TODAY(),""y"")"
voici mon code au complet:
Code: 
Dim numLigneVide As Long
Dim agepersonne As Integer

Worksheets("Liste de la clientel").Activate
  'On trouve la dernière ligne vide du tableau et on enregistre le numéro de la ligne dans la variable
  numLigneVide = Range("A" & Rows.Count).End(xlUp).Row
 ' With "Liste de la clientel"
  
        If TextNom.Text = "" Then
        MsgBox "Veuillez remplir le nom de votre contact", vbCritical, "Champs manquant"
        TextNom.SetFocus
        ElseIf Textprenom.Text = "" Then
        MsgBox "Veuillez remplir le prénom de votre contact", vbCritical, "Champs manquant"
        Textprenom.SetFocus
        ElseIf IsNumeric(TextNom.Text) Then
         MsgBox "Le nom ne dois pas comporter de chiffres", vbCritical, "Champs manquant"
        TextNom.SetFocus
         ElseIf IsNumeric(Textprenom.Text) Then
         MsgBox "Le prénom ne dois pas comporter de chiffres", vbCritical, "Champs manquant"
        TextNom.SetFocus
        
        Else
        'On remplit les données dans notre tableau
        ActiveSheet.Cells(numLigneVide, 1) = TextNom.Text
        ActiveSheet.Cells(numLigneVide, 2) = Textprenom.Text
        ActiveSheet.Cells(numLigneVide, 3) = DateText.Text
         
    agepersonne = ActiveCell.FormulaR1C1 = DATEDIF(c1, Today(), "y")
   
        
         ActiveSheet.Cells(numLigneVide, 4) = agepersonne
        'On efface le formulaire et on replace le curseur sur le premier champs (Nom)
        TextNom.Text = ""
        Textprenom.Text = ""
        End If
 
Dernière édition:
Trier par date Trier par votes
O

oxydedefer

XLDnaute Nouveau
Re : Calculé age d 'une personne au jour près

Merci à vous deux pour vos réponse , le problème c'est que je comprend pas où est mon erreur dans mon code si dessus , lorsque j'utilise la fonction DATEDIF sur excel en manuel il y a pas de soucis ,mais dès que je l 'incorpore dans mon code grâce a une macro il me met 0 :s , merci PierreJean je vais essayer de décortiqué et comprendre ton code .
 
Vote positif 0 Vote négatif
Modeste geedee

Modeste geedee

XLDnaute Barbatruc
Re : Calculé age d 'une personne au jour près

Bonsour®
oxydedefer à dit:
le problème c'est que je comprend pas où est mon erreur dans mon code si dessus , lorsque j'utilise la fonction DATEDIF sur excel en manuel il y a pas de soucis ,mais dès que je l 'incorpore dans mon code grâce a une macro il me met 0 :s ,
Cliquez pour agrandir...

agepersonne = ActiveCell.FormulaR1C1 = DATEDIF(c1, Today(), "y")
Cliquez pour agrandir...
Comparaison logique !!!!
la variable agepersonne reçoit alors un booléen : VRAI /FAUX -1/0

Code: 
ActiveCell.Formula= "=DATEDIF(C1,TODAY(),""y"")"
agepersonne = ActiveCell.Value

à noter :
la fonction DATEDIF est buggée lors de l'utilisation de l"argument "md"
  • lorsque la date la plus récente est dans une année bissextile
    ET
  • lorsque le mois de cette date est janvier
    ET
  • lorsque le jour de cette date est inferieur au jour de la date la plus ancienne

=DATEDIF("24/07/1941";"04/01/2012";"md")
Cliquez pour agrandir...
affichage : 125
 
Vote positif 0 Vote négatif
Modeste geedee

Modeste geedee

XLDnaute Barbatruc
Re : [VBA]Calculé age d 'une personne au jour près

Bonsour®
oxydedefer à dit:
moi il y a que les année qui m'intéresse , je peux me fié à cette fonction ?
Cliquez pour agrandir...

age en années :
Code: 
= ENT((ABS(Date1-Date2))/365,25)
catégoriquement concernant DATEDIF : NON !!!
cette fonction n'est pas fiable ...

PierreJean a créé une fonction personnalisée DIFDAT hors de soupçon...
Lien supprimé
 
Vote positif 0 Vote négatif
Misange

Misange

XLDnaute Barbatruc
Re : [VBA]Calculé age d 'une personne au jour près

Bonjour
et encore celle-ci , DiffDate de Frédéric Sigonneau, le maître du temps :)
Ce lien n'existe plus
d'une façon générale, le site de Frédéric est une référence dès qu'il s'agit des problèmes de dates (et sur beaucoup d'autres choses aussi d'ailleurs !)

Ce site n'existe plus
 
Vote positif 0 Vote négatif
Misange

Misange

XLDnaute Barbatruc
Re : [VBA]Calculé age d 'une personne au jour près

regarde ici
Ce lien n'existe plus
une fois que tu as fait ça dans la feuille de calcul tu tapes
=LeNomDeLaFonction(LesParamètres)
par exemple
=DiffDates(A1;A2)
c'est en regardant la fonction que tu sais ce qu'elle attends comme paramètres
par exemple

Function DIFFDATES(Debut, Fin, Optional Renvoi As Integer = 1) As String
signifie qu'elle attend au moins deux paramètres indiquant le début et la fin
donc une cellule contenant une date de début (date de naissance)
une contenant la date de fin (par exemple aujourdhui() )

pour les paramètres optionnels tu les trouve ici à la fin de la fonction :
'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

donc si tu dis
= diffdates(A1; B1; 3)
tu récupères juste le nombre d'années. PAr défaut tu récupères les années mois et jours.
 
Vote positif 0 Vote négatif
O

oxydedefer

XLDnaute Nouveau
Re : [VBA]Calculé age d 'une personne au jour près

AAArrrgg je n' y arrive pas , sa m'énerve ! voilà ce que j obtient comme erreur :

mon code:
Code: 
Private Sub CommandButton1_Click()
Dim numLigneVide As Long
Dim agepersonne As Integer
Dim debut As Date
Dim fin As Date


Worksheets("Liste de la clientel").Activate
  'On trouve la dernière ligne vide du tableau et on enregistre le numéro de la ligne dans la variable
  numLigneVide = Range("A" & Rows.Count).End(xlUp).Row
 ' With "Liste de la clientel"
  
        If TextNom.Text = "" Then
        MsgBox "Veuillez remplir le nom de votre contact", vbCritical, "Champs manquant"
        TextNom.SetFocus
        ElseIf TextPrenom.Text = "" Then
        MsgBox "Veuillez remplir le prénom de votre contact", vbCritical, "Champs manquant"
        TextPrenom.SetFocus
        ElseIf IsNumeric(TextNom.Text) Then
         MsgBox "Le nom ne dois pas comporter de chiffres", vbCritical, "Champs manquant"
        TextNom.SetFocus
         ElseIf IsNumeric(TextPrenom.Text) Then
         MsgBox "Le prénom ne dois pas comporter de chiffres", vbCritical, "Champs manquant"
        TextNom.SetFocus
        
        Else
        'On remplit les données dans notre tableau
        ActiveSheet.Cells(numLigneVide, 1) = TextNom.Text
        ActiveSheet.Cells(numLigneVide, 2) = TextPrenom.Text
        ActiveSheet.Cells(numLigneVide, 3) = DateText.Text
         debut = DateText.Text
         fin = today
         
        Call DIFFDATES(debut, fin, 3)
    
         'ActiveSheet.Cells(numLigneVide, 4)
        'On efface le formulaire et on replace le curseur sur le premier champs (Nom)
        TextNom.Text = ""
        TextPrenom.Text = ""
        End If


le code du module:
Code: 
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
*DIFFDATES = CVErr(xlErrValue) Voila où sa bug*
Désolé d'être aussi nul . . .
 
Vote positif 0 Vote négatif
pierrejean

pierrejean

XLDnaute Barbatruc
Re : [VBA]Calculé age d 'une personne au jour près

Re

Salut à tous :)

@ la rouille (pardon.... oxydedefer)
Si tu avais pris la peine de nous fournir un petit fichier exemple (ou une copie de ton fichier sans données confidentielles ) le problème serait réglé depuis belle lurette
Il nous reste l'interet de decouvrir les diverses solutions permettant d'echapper à Diffdate
 
Vote positif 0 Vote négatif

Discussions similaires

S
  • Question
comment rendre une combobox plus rapide
Réponses
5
Affichages
1 K
snoopy07
S
J
  • Question
probleme date vba
Réponses
8
Affichages
37 K
judoka0209
J
R
  • Question
ouvrir un fichier excel depuis un autre fichier avec VBA
Réponses
7
Affichages
3 K
bbb38
bbb38
J
  • Question
Problème Bouton Fermer
Réponses
5
Affichages
2 K
Jacky.25
J
P
  • Question
aide sur correction VBA
Réponses
13
Affichages
2 K
kjin
K
C
  • Question
ouvrir et fermer une userform
Réponses
1
Affichages
2 K
Christian3000
C
S
  • Question
probleme données dans cellules
Réponses
5
Affichages
868
JNP
JNP
C
  • Question
Report infos USF dans un fichier, choix dernière ligne
Réponses
6
Affichages
1 K
CATA56
C
S
  • Question
Creer une liste déroulante dans un formulaire
2
Réponses
25
Affichages
3 K
sonic730
S
D
  • Question
Problème avec une ligne visual basic
Réponses
9
Affichages
1 K
MJ13
MJ13

Membres actuellement en ligne

14 membres et 125 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
312 164
Messages
2 085 864
Membres
103 007
dernier inscrit
salma_hayek