Conversión de número a letras

Option Explicit Option Base 0 Public Enum Pays France Belgique Suisse End Enum Public Enum Devise Aucune Euro FrancSuisse Dollar End Enum Dim jusqueSeize As Variant Dim dizaines As Variant Dim resultat() As String Dim troisChiffres() As Integer 'tabla que separa la parte entera en trozos de 3 cifras 'Función que escribe el número en letras 'Nombre es el número a escribir 'ElPaís es el país de uso, para especificaciones regionales. Se trata de un enumerable definido más arriba, los valores posibles son: ' Francia o 0 ' Bélgica o 1 ' Suiza o 2 'LaDevise la moneda a usar en su caso. Los valores posibles son: ' Ninguna o 0 ' Euro o 1 ' FrancSuisse o 2 ' Dollar o 3 Public Function ToLettres(ByVal Nombre As Double, Optional ByVal LePays As Pays = Pays.France, Optional ByVal LaDevise As Devise = Devise.Aucune) As String ReDim resultat(0) ReDim troisChiffres(0) Select Case Sgn(Nombre) Case -1 AjouteResultat "moins " Nombre = Nombre * -1 Case 0 ToLettres = jusqueSeize(0) Exit Function End Select If Nombre >= 2147483647 Then 'utilizo un long para la parte entera y es el valor máximo ToLettres = "Nombre trop grand" Exit Function End If jusqueSeize = Array("zéro", "un", "deux", "trois", "quatre", "cinq", "six", "sept", "huit", "neuf", "dix", "onze", "douze", "treize", "quatorze", "quinze", "seize") dizaines = Array("rien", "dix", "vingt", "trente", "quarante", "cinquante", "soixante", "soixante", "quatre-vingt", "quatre-vingt") Dim PartieEntiere As Long PartieEntiere = CLng(Fix(Nombre)) Dim partieDecimale As Double partieDecimale = Nombre - PartieEntiere Dim milliers As Variant milliers = Array("", "mille", "million", "milliard", "billion", "billiard") If PartieEntiere > 0 Then Do While PartieEntiere > 0 AjouteTroisChiffres CInt(Fix(PartieEntiere Mod 1000)) PartieEntiere = PartieEntiere \ 1000 Loop Dim reste As Double reste = Nombre - PartieEntiere Dim i As Integer For i = UBound(troisChiffres) - 1 To 0 Step -1 Dim leNombre As Integer leNombre = troisChiffres(i) If leNombre > 1 Then 'valeurs de milliers au pluriel AjouteResultat Ecrit3Chiffres(troisChiffres(i), LePays, i = 0) 'pour 400 000, cent ne prend pas de S alors que pour 400 si If i > 1 Then ' mille est invariable et "" ne prend pas de s AjouteResultat milliers(i) & "s" ElseIf i = 1 Then AjouteResultat milliers(i) End If ElseIf leNombre = 1 Then If i <> 1 Then 'dix un million, mais pas un mille AjouteResultat "un" End If AjouteResultat milliers(i) End If 'on ne traite pas le 0, car on ne dit pas X millions zéro mille Y. Next i Else AjouteResultat jusqueSeize(0) End If Select Case LaDevise Case Devise.Dollar AjouteResultat "$" Case Devise.Euro AjouteResultat "€" Case Devise.FrancSuisse AjouteResultat "CHF" End Select If LaDevise <> Devise.Aucune Then partieDecimale = Round(partieDecimale, 2) If partieDecimale <> 0 Then AjouteResultat "et" AjouteResultat Ecrire2Chiffres(CInt(Fix(partieDecimale * 100)), LePays) AjouteResultat "centimes" End If Else milliers = Array("millième", "millionième", "milliardième") 'con la imprecisión de los números con coma flotante, 1234562.789 - 1234562 da 0.78900000010617077 hay que contar el número de cifras decimales del número original y redondear el resultado de la resta Dim morceaux() As String morceaux = Split(CStr(Nombre), ",") 'por defecto ToString redondea a 10^-8, el formato G25 obliga a escribir 25 caracteres si están presentes, sea (como máximo) 15 antes de la coma, la coma y 9 después, split permite descomponer la cadena obtenida If UBound(morceaux) = 1 Then 'hay una parte decimal AjouteResultat "et" Dim lenghtPartieDecimale As Integer lenghtPartieDecimale = Len(morceaux(1)) If lenghtPartieDecimale > 9 Then lenghtPartieDecimale = 9 'limitamos a 10^-9 End If partieDecimale = Round(partieDecimale, lenghtPartieDecimale) i = 0 Do While partieDecimale > 0 partieDecimale = partieDecimale * 1000 Dim valeur As Integer valeur = CInt(Fix(partieDecimale)) lenghtPartieDecimale = lenghtPartieDecimale - 3 If lenghtPartieDecimale < 0 Then lenghtPartieDecimale = 0 End If partieDecimale = Round(partieDecimale - valeur, lenghtPartieDecimale) If valeur <> 0 Then AjouteResultat Ecrit3Chiffres(valeur, LePays, False) '0.400 cent ne prend pas d's car il y a millième après If valeur > 1 Then AjouteResultat milliers(i) & "s" i = i + 1 Else AjouteResultat milliers(i) i = i + 1 End If End If Loop End If End If ToLettres = Trim(Join(resultat, " ")) End Function 'Ecrit les nombres de 0 à 999 Private Function Ecrit3Chiffres(ByVal Nombre As Integer, ByVal LePays As Pays, RegleDuCent As Boolean) As String If Nombre = 100 Then Ecrit3Chiffres = "cent" Exit Function End If If Nombre < 100 Then Ecrit3Chiffres = Ecrire2Chiffres(Nombre, LePays) Exit Function End If Dim centaine As Integer centaine = Nombre \ 100 Dim reste As Integer reste = Nombre Mod 100 If reste = 0 Then 'Cent prend un s cuando está multiplicado y no seguido por una palabra, como el caso de 100 ya está tratado, estamos ante un múltiplo If RegleDuCent = True Then Ecrit3Chiffres = jusqueSeize(centaine) & " cents" Else 'para 400 000 por ejemplo el cent no toma s Ecrit3Chiffres = jusqueSeize(centaine) & " cent" End If Exit Function End If If centaine = 1 Then Ecrit3Chiffres = "cent " & Ecrire2Chiffres(reste, LePays) 'no decimos un cent X, sino cent X Exit Function End If Ecrit3Chiffres = jusqueSeize(centaine) & " cent " & Ecrire2Chiffres(reste, LePays) End Function 'Ecrit les nombres de 0 à 99 Private Function Ecrire2Chiffres(ByVal Nombre As Integer, ByVal LePays As Pays) As String If LePays <> Pays.France Then dizaines(7) = "septante" dizaines(9) = "nonante" End If If LePays = Pays.Suisse Then dizaines(8) = "huitante" End If If Nombre < 17 Then Ecrire2Chiffres = jusqueSeize(Nombre) Exit Function End If Select Case Nombre 'cas particuliers de 71, 80 et 81 Case 71 'en Francia 71 toma un et If LePays = Pays.France Then Ecrire2Chiffres = "soixante et onze" Exit Function End If Case 80 'en France et Belgique le vingtaine prend un s If LePays = Pays.Suisse Then Ecrire2Chiffres = dizaines(8) Exit Function Else Ecrire2Chiffres = dizaines(8) & "s" Exit Function End If Case 81 'en France et Belgique il n'y a pas de et If LePays <> Pays.Suisse Then Ecrire2Chiffres = dizaines(8) & "-un" Exit Function End If End Select Dim dizaine As Integer dizaine = Nombre \ 10 Dim unite As Integer unite = Nombre Mod 10 Dim laDizaine As String laDizaine = dizaines(dizaine) If LePays = France And (dizaine = 7 Or dizaine = 9) Then dizaine = dizaine - 1 unite = unite + 10 End If Select Case unite Case 0 Ecrire2Chiffres = laDizaine Case 1 Ecrire2Chiffres = laDizaine & " et un" Case 17, 18, 19 'para 77 a 79 y 97 a 99 unite = unite Mod 10 Ecrire2Chiffres = laDizaine & "-dix-" & jusqueSeize(unite) Case Else Ecrire2Chiffres = laDizaine & "-" & jusqueSeize(unite) End Select End Function 'Ajoute une valeur al tableau Sub AjouteResultat(ByVal Texte As String) If IsArray(resultat) Then Dim taille As Integer taille = UBound(resultat) + 1 Else taille = 1 End If ReDim Preserve resultat(taille) resultat(taille - 1) = Texte End Sub 'ajoute une valeur al tableau Sub AjouteTroisChiffres(ByVal Entier As Integer) If IsArray(troisChiffres) Then Dim taille As Integer taille = UBound(troisChiffres) + 1 Else taille = 1 End If ReDim Preserve troisChiffres(taille) troisChiffres(taille - 1) = Entier End Sub 

 'code de prueba Sub test() ActiveSheet.Range("A1") = ToLettres(123.456) ActiveSheet.Range("A2") = ToLettres(3210987654321.2) ActiveSheet.Range("A3") = ToLettres(123456789012345#) ActiveSheet.Range("A4") = ToLettres(1234.123456789) ActiveSheet.Range("A5") = ToLettres(-4321.987654321) ActiveSheet.Range("A6") = ToLettres(1E+16) 'este número es demasiado grande ActiveSheet.Range("A7") = ToLettres(0.12345678961) 'hay demasiados dígitos tras la coma, el resultado se redondeará ActiveSheet.Range("A8") = ToLettres(6795432.456, Belgique, Euro) 'para las opciones se pueden usar las "palabras clave" ActiveSheet.Range("A9") = ToLettres(400400400, 0, 0) 'para las opciones se pueden usar los números correspondientes a las "palabras clave" ActiveSheet.Range("A10") = ToLettres(0.4) End Sub