Conversión de número a letras

Hola y gracias a los que utilizan VB.NET

Y en VBA

 Option Explicit Option Base 0 Public Enum Pays Francia Bélgica Suiza End Enum Public Enum Devise Ninguna Euro FrancSuisse Dólar End Enum Dim jusqueCatorce Como Variant Dim dizaines Como Variant Dim resultat() Como String Dim troisChiffres() Como Integer 'tabla que divide la parte entera en trozos de 3 dígitos '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 especificidades regionales 'LaMoneda la moneda a utilizar en su caso</param> 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 'uso 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 Como Long partieEntiere = CLng(Fix(Nombre)) Dim partieDecimale As Double partieDecimale = Nombre - partieEntiere Dim milliers Como 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 'valores de miles en plural AjouteResultat Ecrit3Chiffres(troisChiffres(i), LePays) If i > 1 Then ' mille es invariable y "" no toma s AjouteResultat milliers(i) & "s" ElseIf i = 1 Then AjouteResultat milliers(i) End If ElseIf leNombre = 1 Then If i <> 1 Then 'se dice un millón, pero no un mil AjouteResultat "un" End If AjouteResultat milliers(i) End If 'no tratamos el 0, porque no se dice X millones cero mil 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 Entonces 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 imprecision de los números con coma flotante, 1234562.789 - 1234562 da 0.78900000010617077 hay que contar el número de dígitos decimales del número original y redondear el resultado de la resta Dim morceaux() Como String morceaux = Split(CStr(Nombre), ",") 'por defecto ToString redondea a 10^-8, el formato G25 obliga a escribir 25 caracteres si están presentes, para evitar 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) 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 = Join(resultat, " ") End Function 'Escribe los números de 0 a 999 Private Function Ecrit3Chiffres(ByVal Nombre As Integer, ByVal LePays As Pays) 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 lleva una s cuando es múltiplo y no va seguido de un número, como en el caso de 100 ya tratado, nos encontramos ante un múltiplo Ecrit3Chiffres = jusqueSeize(centaine) & " cents" 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 'Escribe los números de 0 a 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 'casos particulares de 71, 80 y 81 Case 71 'en Francia 71 lleva un et If LePays = Pays.France Then Ecrire2Chiffres = "soixante et onze" Exit Function End If Case 80 'en Francia y Bélgica la veintena lleva una s If LePays = Pays.Suisse Then Ecrire2Chiffres = dizaines(8) Exit Function Else Ecrire2Chiffres = dizaines(8) & "s" Exit Function End If Case 81 'en Francia y Bélgica no hay 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 'Añade un valor al arreglo Sub AjouteResultat(ByVal Texte As String) On Error GoTo TableauVide 'el manejo de error es el único caso en que me permito los goto Dim taille As Integer taille = UBound(resultat) + 1 ReDim Preserve resultat(taille) resultat(taille - 1) = Texte Exit Sub TableauVide: ReDim resultat(1) resultat(0) = Texte End Sub 'agrega un valor al arreglo Sub AjouteTroisChiffres(ByVal Entier As Integer) On Error GoTo TableauVide 'el manejo de error es el único caso en que me permito los goto Dim taille As Integer taille = UBound(troisChiffres) + 1 ReDim Preserve troisChiffres(taille) troisChiffres(taille - 1) = Entier Exit Sub TableauVide: ReDim troisChiffres(1) troisChiffres(0) = Entier End Sub 'codigo 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, Bélgica, Euro) End Sub 

Hay 2 goto para el manejo de errores, porque no encuentro cómo saber que un arreglo no tiene tamaño:

 Dim toto() UBound(toto)'devuelve un error, porque el arreglo aún no tiene tamaño redim toto(1) 

@Usuario anónimoHola,

Gracias por este código, ¿en qué momento una matriz no estaría definida ??

test si tableau: Sub test() Dim toto If IsArray(toto) Then MsgBox "ok" ReDim toto(1) x = UBound(t) Else Msgbox"pas tableau" End If End Sub

@f894009Gracias, aquí están las 2 funciones corregidas.

 'Añade un valor al array 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 'añade un valor al array 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

VBA no es lo mío, VB6, lo dejé hace más de 10 años.
Lo mejor sería probablemente inicializar las matrices directamente al tamaño correcto.
Pero no he buscado mucho por ese lado.

@Usuario anónimoHola a todos,

No he tenido todavía tiempo de probar vuestro código Whismeril, pero lo haré tan pronto como sea posible.
Para evitar la Etiqueta Goto, puedes optar por una gestión de errores "simple" o no subsistirá más que el Goto 0 de cancelación (no necesariamente útil, pero más "limpio") :

Sub AjouteResultat(ByVal Texte As String) Dim taille As Integer On Error Resume Next taille = UBound(resultat) + 1 If (Err.Number <> 0) Then taille = 1 'La ligne suivante peut être supprimée car pas très utile On Error GoTo 0 ' ==> seul Goto subsistant. ReDim Preserve resultat(taille) resultat(taille - 1) = Texte End Sub

@f894009 : Le problème de Whismeril n'est pas de savoir s'il a un Array ou non, il en a de part ses déclarations. Mais c'est d'utiliser UBound même lorsqu'aucune valeur n'a été mise dans son Array dynamique. IsArray est ici inopérant :

Sub test() Dim toto If IsArray(toto) Then MsgBox "ok" x = UBound(t) 'Erreur 9 l'indice n'appartient pas à la sélection ReDim toto(1) x = UBound(t) Else Msgbox"pas tableau" End If End Sub

Tu es forcé à un moment d'utiliser la gestion d'erreur si tu veux savoir si ton Array s'est déjà vu allouer une valeur, sauf à le dimensionner initialement...

En ce qui concerne le Goto, mon opinion est qu'il n'y a pas de contre-indication à l'utiliser, mais, qu'il faut éloigner cet outil des mains des débutants.

Finalmente

lo reuní todo allí
https://codes-sources.commentcamarche.net/source/101858-ecrire-des-nombres-en-lettre-c-vb-net-et-vba

@Usuario anónimoHola,
Acabo de pasar el enlace a una persona para VBA Access
https://forums.commentcamarche.net/forum/affich-34424898-convertir-un-nombre-en-lettres-dans-access-etat#p34427270