'********************************************************************************
' NOMBRE EN LETTRE version Francaise *
'auteur: patricktoulon sur exceldownload *
'version 1.0 à 6.3 supprimées *
'version 7.0 *
'Date version 15 novembre 2020------------------------ *
'refonte complete du moteur de convertion (simplifié dans un select case) *
'Ajout du moteur d'association a une mesure(monnaie ou autre) *
'merge des modeles nombre et monnaie en une seule fonction *
'sans association ou monnaie ou mesure concernée 3 chiffres après la virgule *
'on va toujours jusqu'a 999 deciliards (9999.....) EN STRING!!!!! *
'on va jusqu'au billion en formule et en long en VBA *
'because vba et excel abrege les nombre au delas!!!! *
' *
' <<<monnaie et mesure deja intégrées>>> *
' *
'sans mesure (3 chiffres après la virgule presents ou pas)(pas d'arrondi)*
'EURO (2 chiffres après la virgule)(pas d'arrondi) *
'DOLLAR (2 chiffres après la virgule)(pas d'arrondi) *
'dinar koweiti (3 chiffres après la virgule)(pas d'arrondi) *
'dinar tunisien (3 chiffres après la virgule)(pas d'arrondi) *
'dirham marocain (2 chiffres après la virgule)(pas d'arrondi) *
'kilo (3 chiffres après la virgule)(pas d'arrondi) *
' *
'mise a jour 26/10/2020------------------------- *
'ajout du choix de l'arrondi 3 eme argument 4 choix possibles (-1,0,1,2) *
'-1 ou pas d'argument =pas d'arrondi (par defaut si omis) *
'0=arrondi inferieur (RoundDown) *
'1=arrondi automatique (round) *
'2=arrondi superieur(RoundUp) *
' *
'mise a jour 27/10/2020-------------------------- *
'Ajout de la monnaie suedoise "le couronne" (demande de @Jouxte)(XLD) *
' *
'mise a jour 27/10/2020-------------------------- *
'refonte du moteur d'arrondi simplifié *
'néanmoins un bug reside dans le multiple de 1 pour l'entier vallant 1 *
'avec l'arrondi vba,superieur,inférieur *
' *
'mise a jour 28/10/2020--------------------------- *
'correction du bug de l'arrondi en bloquant l'arrondi en dessous 1.10(inutile) *
' *
' *
'*********************************************************************************************************
' exemples d'appel de la fonction *
' *
'Debug.Print NblettreFR2020( [nombre] , [monnaie ou nombre de decimal] , [mode d'arrondi] ) *
'Debug.Print NblettreFR2020( [nombre] ) '2 decimales automatique pas d'arrondi *
'Debug.Print NblettreFR2020( [nombre],[2 ou 3] ) '2 ou 3 decimales pas d'arrondi *
'Debug.Print NblettreFR2020([nombre], decRound:=2) '2 decimales forcées arrondi au 10eme superieur *
'Debug.Print NblettreFR2020([nombre], ,2) '2 decimales forcées arrondi au 10eme superieur *
'Debug.Print NblettreFR2020([nombre],2 ) '2 decimales forcées et pas d'arrondi *
'Debug.Print NblettreFR2020([nombre],3,2 ) '3 decimales forcées arrondi au 10eme superieur *
'Debug.Print NblettreFR2020([nombre],3,1 ) '3 decimales forcées arrondi automatique VBA *
'Debug.Print NblettreFR2020([nombre],3,0 ) '3 decimales forcées arrondi au 10eme inférieur *
' *
'*********************************************************************************************************
'****************************************************************************************************************
' exemple d'utilisation en formule *
' *
' à 2 decimales *
'=NblettreFR2020(A1,2,) 'lecture tel quel 2 decimales considérées(la 3eme est occulté si presente) *
'=NblettreFR2020(A1,2,0) 'arrondi inférieur 2 decimales considérées(la 3eme est occulté si presente) *
'=NblettreFR2020(A1,2,1) 'arrondi automatique 2 decimales considérées(la 3eme est occulté si presente)(+/-5) *
'=NblettreFR2020(A1,2,2) 'arrondi supérieur 2 decimales considérées(la 3eme est occulté si presente) *
' *
' à 3 decimales *
'si moins de 3 elle sont ajoutées"#00"(reconsidération de l'echelle de la tranche) *
'=NblettreFR2020(A1,3,)) 'lecture tel quel 3 decimales considérées *
'=NblettreFR2020(A1,3,0)) 'arrondi inférieur 3 decimales considérées *
'=NblettreFR2020(A1,3,1)) 'arrondi automatique 3 decimales considérées (+/-5) *
'=NblettreFR2020(A1,3,2)) 'arrondi supérieur 3 decimales considérées *
' *
' *
' avec les monnaies *
' *
'=NblettreFR2020($A2;"Couronne") 'monnaie couronne 2 decimales (couronne/öre)(féminin) *
'=NblettreFR2020($A2;"dinark") 'monnaie dinar kuweiti 3 decimales (dinar/fil) *
'=NblettreFR2020($A2;"dinar") 'monnaie dinar 3 decimales (dinar/millime) *
'=NblettreFR2020($A2;"Dollar") 'monnaie US 2 decimales (dollar/cent) *
'=NblettreFR2020($A2;"euro") 'monnaie europe 2 decimales (euro/centime) *
'=NblettreFR2020($A2;"£")ou"Ls" 'monnaie Livre Sterling 2 decimales (livre sterling/(peny/pence)) *
'=NblettreFR2020($A2;"dirhammarocain") 'monnaie marocaine 2 decimales (dirham/rial) *
' *
' *
' D'autres mesures *
' *
'=NblettreFR2020($A2;"kilo") 'poids 3 decimales (kilo/gramme) *
' *
' *
' d'autre a venir à la demande :) *
'****************************************************************************************************************
Option Explicit
Sub test()
NblettreFR2020 1000000
NblettreFR2020 1000000.767, 3, 2
NblettreFR2020 1.01, 2, 2
End Sub
Sub testj()
NblettreFR2020 0.75
End Sub
Public Function NblettreFR2020(chain As String, Optional MonnaieOuNombreDeDecimale As String = "", Optional decRound As Long = -1) As String
Dim t, p&, q$, cent$, cx&, d$, u$, Part, ms, Ul, Diz, I&, et$, centime, w$, x&, z, z1, texte, prefixe$, pluriel$, AvecCent$, fric, dec
Ul = Array("", "un", "deux", "trois", "quatre", "cinq", "six", "sept", "huit", "neuf", "dix", "onze", "douze", "treize", "quatorze", "quinze", "seize", "dix-sept", "dix-huit", "dix-neuf")
Diz = Array("", "dix", "vingt", "trente", "quarante", "cinquante", "soixante", "soixante-dix", "quatre-vingt", "quatre-vingt-dix", "cent")
ms = Array("", " decilliard", " decillion", " nonilliard", " nonillion", " octillard", " octillion", " septilliard", " septillion", " sextilliard", " sextillion", " quintilliard ", " Quintillion", " quadrilliard", " quadrillion", " trilliard", " trillion", " Billiard", " billion", " milliard", " million", " mille", "")
chain = Replace(chain, ".", ",") 'au cas ou
If Not IsNumeric(chain) Then NblettreFR2020 = "Invalid Chain!!!": Exit Function
Part = Split(chain, ","): If Len(Part(0)) > 66 Then NblettreFR2020 = "OutOFF(CAR*66)!!": Exit Function
fric = MonnaieOuNombreDeDecimale
'--------------------------------------------------------------------------------------------
'moteur d'association
Select Case LCase(fric)
Case "", 2: fric = IIf(UBound(Part) > 0, "virgule", ""): centime = "": cx = 2: pluriel = ""
Case 3: fric = IIf(UBound(Part) > 0, "virgule", ""): centime = "": cx = 3: pluriel = ""
Case "euro": centime = "centime": cx = 2: prefixe = "d'": AvecCent = " et":: pluriel = "s": ' decRound = -1
Case "dollar": centime = "cent": cx = 2: prefixe = "de ": pluriel = "s": AvecCent = " et": ' decRound = -1
Case "dinark", "dinar": decRound = -1: centime = IIf(fric = "dinark", "fil", "millime"): fric = "dinar": cx = 3: prefixe = "de ": pluriel = "s": AvecCent = " et"
Case "kilo": decRound = -1: centime = "gramme": cx = 3: prefixe = "de ": pluriel = "s": AvecCent = " et"
Case "dirhammarocain": fric = "dirham": centime = "rial": cx = 2: pluriel = "s": AvecCent = " et": prefixe = "de "
Case "£": fric = "Livre Sterling": prefixe = "of ": AvecCent = " et ": pluriel = "": cx = 2: If UBound(Part) > 0 Then If Part(1) > 1 Then centime = "pence" Else centime = "peny"
Case "couronne": centime = "Öre": cx = 2: prefixe = "de ": AvecCent = " et":: pluriel = "": fric = IIf(Part(0) > 1, fric & "s", fric)
'......
'.....
End Select
'--------------------------------------------------------------------------------------------
'Moteur de l'arrondi
If CDbl(chain) < 1.1 Then decRound = -1 '(inutile de descendre en dessous)
If decRound <> -1 Then
Select Case decRound
Case 0: chain = WorksheetFunction.RoundDown(chain, cx - 1):
Case 1: chain = WorksheetFunction.Round(chain, cx - 1):
Case 2: chain = WorksheetFunction.RoundUp(chain, cx - 1):
End Select
Part = Split(chain, ",")
End If
If UBound(Part) > 0 Then Part(1) = Left(Part(1), cx)
'--------------------------------------------------------------------------------------------
fric = IIf(Val(Part(0)) > 999000 And Val(Right(Part(0), 6)) = 0, prefixe & fric, fric) 'ajout du prefixe a partir de 1 million si mod 10
fric = IIf(Part(0) > 1, fric & pluriel, fric) & IIf(UBound(Part) > 0, AvecCent, "")
If UBound(Part) > 0 Then Part(1) = Left(Part(1), cx): centime = IIf(Part(1) > 1 And centime <> "", centime & pluriel, centime)
If Val(Part(0)) = 0 Then NblettreFR2020 = "zero" & fric
For I = 0 To UBound(Part)
If I = 0 Then
t = Split(Trim(Format(Part(I), Application.Rept(" @@@", (Len(Part(I)) / 3) + 1))), " ")
Else
t = Array(CStr(Left(Part(1) & "00", cx)))
End If
cent = "": d = "": u = ""
For p = UBound(t) To 0 Step -1
'--------------------------------------------------------------------------------------------
'Moteur de conversion
cent = "": d = "": u = "": z1 = t(p): z = t(p)
If z >= 100 Then cent = IIf(Left(z, 1) > 1, Ul(Left(z, 1)) & " cent", "cent")
If z Mod 100 = 0 And z > 100 Then cent = cent & "s" Else cent = cent & " "
z = Right(z1, 2)
Select Case True
Case z < 20: d = "": u = Ul(z) 'si en dessous de 20 on passe directement par l'array ul
Case z > 70 And z < 80: et = IIf(Right(z, 1) = 1, " et ", "-"): d = Diz(Left(z, 1) - 1): u = et & Ul(Right(z, 1) + 10) 'de 71 a 79 c'est dizaine-1 et unité+10 pour 71 et =" et " sinon et="-"
Case z = 80: d = Diz(Left(z, 1)) & "s" 'exeption seul le 80 tout seul prends le "s"
Case z > 90: d = Diz(Left(z, 1) - 1): u = "-" & Ul(Right(z, 1) + 10) 'de 91 a 99 c'est dizaine-1 et unité+10 le et est automatiquement "-"
'pour tout le reste c'est dizaine et unité
Case Else: et = IIf(Right(z, 1) = "0" Or z < 10, "", IIf(Right(z, 1) = 1, "-et-", "-")): d = Diz(Left(z, 1)): u = et & Ul(Right(z, 1)) 'If Right(z, 1) = "0" Or z < 10 Then et = "" Else et = "-"
End Select
'fin de conversion
'--------------------------------------------------------------------------------------------
'compile du segment
t(p) = Trim(cent & d & u) & " " & IIf(I = 0, IIf(z1 > 0, ms(UBound(ms) - x) & IIf(z1 > 1, IIf(x > 1, "s ", " "), " "), " "), " ")
x = x + 1 'itération pour soustraire index de "ms"
If t(p) = "un mille " Then t(p) = "mille "
If t(p) = " " And Val(Part(I)) = 0 Then t(p) = "Zéro"
'Debug.Print t(p)
Next
If I = 0 Then q = fric Else q = centime 'association mesure accordée
texte = texte & Application.Trim(Join(t, "")) & " " & q & " "
Next
'------------------------------------------------------------------------
'correctif féminin/masculin( pour l'unité de fric et centime) si besoins pour certaines monnaies
Select Case True
Case InStr(1, LCase(texte), "couronne", vbTextCompare) > 0: texte = Replace(texte, "un Couronne", "une Couronne")
'etc....
End Select
'------------------------------------------------------------------------
'compilation et régularisation des espaces de la chaine finale
texte = Application.Trim(texte): If Right(texte, 7) = "virgule" Then texte = Replace(texte, " virgule", "")
'Debug.Print texte'juste pour voir
NblettreFR2020 = texte 'RETURN!!!
End Function