Je propose une solution en BASIC (VBA, écrit dans un classeur Excel).
Placez le code ci-dessous dans un module de classeur Excel :
'DEBUT DU CODE
Option Explicit
Option Base 0
Rem ***** BASIC *****
Function numToAlpha(x As String, Optional u As Boolean = True, Optional v As String = "") As String
' _________________________________ Mémo _________________________________________________________________________________
' Écriture en lettres d'un nombre donné en chiffres
' Fonction créée le 16/07/2003 par ROGER
' Modifiée le 25/07/2008 par ROGER
' x est le nombre donné, de 0 à 999 999 999 999 999 999 (on peut essayer plus grand...)
' u (VRAI par défaut) contrôle l'écriture de 1000 ("mille" si u=1 ou VRAI ou est omis, "mil" si u=0 ou FAUX)
' v ("" par défaut, "d'" ou "de" typiquement) ajoute v à la fin si le nombre se termine par
' "milliard(s)" ou "million(s)".
' =numToAlpha(1948) renvoie mille neuf cent quarante-huit
' =numToAlpha(1948,9) renvoie mille neuf cent quarante-huit (la partie décimale est ignorée)
' =numToAlpha(1948;1) renvoie mille neuf cent quarante-huit
' =numToAlpha(1948;0) renvoie mil neuf cent quarante-huit
' =numToAlpha("1 000 000";;"de francs")
' renvoie un million de francs
' =numToAlpha("876 543 200 980 654 321";1)
' renvoie huit cent soixante-seize millions cinq cent quarante-trois mille deux cents milliards
' neuf cent quatre-vingts millions six cent cinquante-quatre mille trois cent vingt-et-un
' ________________________________________________________________________________________________________________________
If IsMissing(v) Then v = "" Else v = " " & v
numToAlpha = NZ312UX(x, u, v)
End Function
Function NZ312UX(x As String, u As Boolean, v As String) As String
' ATTENTION : Cette fonction est récursive.
Dim it As String, y As String
x = clean1(x)
On Error GoTo annule
If Len(x) <> 0 Then
If x <> "0" Then
If Len(x) > 9 Then y = Left$(x, Len(x) - 9) Else y = "0"
If y <> "0" Then
it = it & NZ312UX(y, u, "") '*** *** *** APPEL RECURSIF DE NZ312UX *** *** ***
If CDec(Right$(y, 6)) = 0 Then it = it & " de"
it = it & " milliard": If y <> "1" Then it = it & "s"
End If
y = CStr(CDec(Right$(x, 9)))
If y <> "0" Then
If it <> "" Then it = it & " "
it = it & t9(y, u): If CDec(Right$(y, 6)) = 0 Then it = it & v
Else: it = it & v
End If
Else
it = NZ312UY(0)
End If
End If
annule:
NZ312UX = it
End Function
Function t9(x As String, Optional u As Boolean = True) As String
Dim it As String, y As String
y = CStr(CDec("0" & Right$(Left$(x, max(0, Len(x) - 6)), 3)))
If y <> "0" Then
it = it & t3(y) & " million": If y <> "1" Then it = it & "s"
End If
y = CStr(CDec("0" & Right$(Left$(x, max(0, Len(x) - 3)), 3)))
If y <> "0" Then
If it <> "" Then it = it & " "
If y <> "1" Then it = it & t3(y, 0) & " "
it = it & "mil": If u Then it = it & "le"
End If
y = CStr(CDec(Right$(x, 3)))
If y <> "0" Then
If it <> "" Then it = it & " "
it = it & t3(y)
End If
t9 = it
End Function
Function t3(x As String, Optional u As Boolean = True) As String
Dim it As String, y As String
If x <> "0" Then
y = CStr(CDec("0" & Left$(x, max(0, Len(x) - 2)))): x = CDec(Right$(x, 2))
If y <> "0" Then
If y <> "1" Then it = NZ312UY(CInt(y)) & " "
it = it & "cent": If x = "0" And y <> "1" And u Then it = it & "s"
End If
If x <> "0" Then
If it <> "" Then it = it & " "
it = it & NZ312UY(CInt(x)): If x = "80" And u Then it = it & "s"
End If
End If
t3 = it
End Function
Function clean1(x As String) As String
Dim it As String, compte As Integer
For compte = 1 To Len(x)
If Mid(x, compte, 1) = "," Then Exit For
If IsNumeric(Mid(x, compte, 1)) And Mid(x, compte, 1) <> " " And Mid(x, compte, 1) <> Chr(160) Then it = it + Mid(x, compte, 1)
Next compte
clean1 = it
End Function
Function clean2(x As String) As String
Dim it As String, compte As Integer
For compte = 1 To Len(x)
If (Mid(x, compte, 1) = "," Or IsNumeric(Mid(x, compte, 1))) And Mid(x, compte, 1) <> " " And Mid(x, compte, 1) <> Chr(160) Then it = it + Mid(x, compte, 1)
Next compte
clean2 = it
End Function
Function min(a As Long, b As Long) As Long
min = (a + b - Abs(a - b)) / 2
End Function
Function max(a As Long, b As Long) As Long
max = (a + b + Abs(a - b)) / 2
End Function
Function NZ312UY(x As Integer) As String
' ATTENTION : Cette fonction est récursive.
Dim a As Variant, s As String
a = Array("zéro", "un", "deux", "trois", "quatre", "cinq", "six", "sept", "huit", "neuf", "dix", "onze", _
"douze", "treize", "quatorze", "quinze", "seize", "vingt", "trente", "quarante", "cinquante", _
"soixante", "quatre-vingt")
Select Case x
Case 0 To 16: s = a(x)
Case 17 To 19: s = a(10 * Int(x / 10)) & "-" & a(x Mod 10)
Case 20 To 69: s = a(15 + Int(x / 10))
If x Mod 10 = 1 Then s = s & " et " & a(x Mod 10) Else If x Mod 10 > 1 Then s = s & "-" & a(x Mod 10)
Case 70 To 99: s = a(18 + Int(x / 20))
If x = 71 Then s = s & " et " & a(x Mod 20) Else If x Mod 20 > 0 Then s = s & "-" & NZ312UY(x Mod 20)
Case Else: s = "?"
End Select
NZ312UY = s
End Function
' ________________________________________________________________________________________________________________________
Function numDecToAlpha(x As String, Optional u As Boolean = True) As String
Dim c As Integer
x = clean2(x)
If Len(x) <> 0 Then
c = InStr(x, ",")
If c <> 0 Then
numDecToAlpha = numToAlpha(Left$(x, c - 1), u) & " virgule "
Do While InStr(Right$(x, Len(x) - c), "0") = 1
numDecToAlpha = numDecToAlpha & "zéro ": c = c + 1
Loop
numDecToAlpha = numDecToAlpha & numToAlpha(Right$(x, Len(x) - c), u)
Else
numDecToAlpha = numToAlpha(x, u)
End If
Else
numDecToAlpha = ""
End If
End Function
Function FRFA(x As String, Optional u As Boolean = True) As String
Dim c As Integer
x = clean2(x)
If Len(x) <> 0 Then
c = InStr(x, ",")
If c <> 0 Then
FRFA = numToAlpha(Left$(x, c - 1), u, "de")
FRFA = FRFA & " franc"
If CDec(x) >= 2 Then FRFA = FRFA & "s"
FRFA = FRFA & " et " & numToAlpha(Mid$(x & "0", c + 1, 2), u) & " centime"
If CDec(Mid$(x, c + 1, 2)) >= 2 Then FRFA = FRFA & "s"
Else
FRFA = numToAlpha(x, u, "de")
FRFA = FRFA & " franc"
If CDec(x) >= 2 Then FRFA = FRFA & "s"
End If
Else
FRFA = ""
End If
End Function
Function EURA(x As String, Optional u As Boolean = True) As String
Dim c As Integer
x = clean2(x)
If Len(x) <> 0 Then
c = InStr(x, ",")
If c <> 0 Then
EURA = numToAlpha(Left$(x, c - 1), u, "d'")
If Right$(EURA, 1) = "'" Then EURA = EURA & "euro" Else EURA = EURA & " euro"
If CDec(x) >= 2 Then EURA = EURA & "s"
EURA = EURA & " et " & numToAlpha(Mid$(x & "0", c + 1, 2), u) & " centime"
If CDec(Mid$(x, c + 1, 2)) >= 2 Then EURA = EURA & "s"
Else
EURA = numToAlpha(x, u, "d'")
If Right$(EURA, 1) = "'" Then EURA = EURA & "euro" Else EURA = EURA & " euro"
If CDec(x) >= 2 Then EURA = EURA & "s"
End If
Else
EURA = ""
End If
End Function
' ________________________________________________________________________________________________________________________
'FIN DU CODE
Utilisation :
Dans une cellule du classeur où est installé le code, essayez :
=numToAlpha(2327) renvoie deux mille trois cent vingt-sept
=numToAlpha(1948;0) renvoie mil neuf cent quarante-huit
=numToAlpha("80 000 000 000 000 000") renvoie quatre-vingts millions de milliards
=EURA("12 895,71 €") renvoie douze mille huit cent quatre-vingt-quinze euros et soixante et onze centimes
=EURA(1000000) renvoie un million d'euros
=numDecToAlpha(5720015698,00519) renvoie cinq milliards sept cent vingt millions quinze mille six cent quatre-vingt-dix-huit virgule zéro zéro cinq cent dix-neuf
Si ça peut servir...
...tant mieux !
11 mai 2008 à 23:36