XL 2013 VBA insérer des retours à la ligne dans un résultat

Jouxte

XLDnaute Occasionnel
Bonjour à toutes et toutes,
J'utilise un code (trouvé sur ce site) qui me permet de calculer un âge pour des dates avant 1900.

VB:
Function CalcAge(dat1 As Date, dat2 As Date) As String
Dim ans%, mois%, jours%
ans = Year(dat2) - Year(dat1) + (DateSerial(2000, Month(dat2), Day(dat2)) < DateSerial(2000, Month(dat1), Day(dat1)))
mois = Month(dat2) - Month(dat1) + (Day(dat2) < Day(dat1))
If mois < 0 Then mois = mois + 12
jours = dat2 - DateSerial(Year(dat2), Month(dat2), Day(dat1))
If jours < 0 Then jours = dat2 - DateSerial(Year(dat2), Month(dat2) - 1, Day(dat1))
CalcAge = IIf(ans, ans & " an" & IIf(ans > 1, "s", IIf(ans < -1, "s", "")), "") & " " & _
    IIf(mois, mois & " mois", "") & " " & IIf(jours, jours & " jour" & IIf(jours > 1, "s", ""), "")
CalcAge = Application.Trim(CalcAge) 'SUPPRESPACE
End Function

Le résultat apparait sur une seule ligne exemple ;
53 ans 3 mois 24 jours
J'aurais souhaité que le résultat apparaisse sur 3 lignes les années sur la première, les mois sur la seconde et les jours sur la troisième.
Par exemple :
53 ans
3 mois
24 jours

Y a-t-il une possibilité ?
Merci par avance pour vos réponses.
 

sylvanu

XLDnaute Barbatruc
Supporter XLD
Bonjour Jouxte,
Le saut de ligne en VBA est vbCrLf.
Donc une possibilité en PJ avec :
VB:
Function CalcAge(dat1 As Date, dat2 As Date) As String
Dim ans%, mois%, jours%
ans = Year(dat2) - Year(dat1) + (DateSerial(2000, Month(dat2), Day(dat2)) < DateSerial(2000, Month(dat1), Day(dat1)))
mois = Month(dat2) - Month(dat1) + (Day(dat2) < Day(dat1))
If mois < 0 Then mois = mois + 12
jours = dat2 - DateSerial(Year(dat2), Month(dat2), Day(dat1))
If jours < 0 Then jours = dat2 - DateSerial(Year(dat2), Month(dat2) - 1, Day(dat1))
CalcAge = IIf(ans, ans & " an" & IIf(ans > 1, "s", IIf(ans < -1, "s", "")), "") & "" & vbCrLf & _
    IIf(mois, mois & " mois", "") & vbCrLf & IIf(jours, jours & " jour" & vbCrLf & IIf(jours > 1, "s", ""), "")
CalcAge = Application.Trim(CalcAge) 'SUPPRESPACE
End Function
Attention, pour être pris en compte il faut que la cellule ait un format Alignement Renvoyer à la ligne
 

Pièces jointes

  • Jouxte.xlsm
    15.1 KB · Affichages: 6

Statistiques des forums

Discussions
291 667
Messages
1 916 973
Membres
179 500
dernier inscrit
oximo
Haut Bas