Number to Words Conversion

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 'array that splits the integer part into chunks of 3 digits 'Function writing the number in words 'Nombre is the number to write 'LePays is the country of use, for regional specificity. It is an enum defined above, possible values are: ' France or 0 ' Belgium or 1 ' Switzerland or 2 'LaDevise the currency to use if applicable. Possible values are: ' None or 0 ' Euro or 1 ' SwissFranc or 2 ' Dollar or 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 "minus " Nombre = Nombre * -1 Case 0 ToLettres = jusqueSeize(0) Exit Function End Select If Nombre >= 2147483647 Then 'I use a long for the integer part and that is the maximum value ToLettres = "Number too large" Exit Function End If jusqueSeize = Array("zero", "one", "two", "three", "four", "five", "six", "seven", "eight", "nine", "ten", "eleven", "twelve", "thirteen", "fourteen", "fifteen", "sixteen") dizaines = Array("nothing", "ten", "twenty", "thirty", "forty", "fifty", "sixty", "sixty", "seventy", "eighty") Dim PartieEntiere As Long PartieEntiere = CLng(Fix(Nombre)) Dim partieDecimale As Double partieDecimale = Nombre - PartieEntiere Dim milliers As Variant milliers = Array("", "thousand", "million", "billion", "trillion", "quadrillion") 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 'plural thousand values AjouteResultat Ecrit3Chiffres(troisChiffres(i), LePays, i = 0) 'for 400,000, hundred does not take an "s" while for 400 it does If i > 1 Then ' thousand is invariable and "" does not take an s AjouteResultat milliers(i) & "s" ElseIf i = 1 Then AjouteResultat milliers(i) End If ElseIf leNombre = 1 Then If i <> 1 Then 'we say one million, but not one thousand AjouteResultat "one" End If AjouteResultat milliers(i) End If 'we do not process 0, as we do not say X million zero thousand 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 "and" AjouteResultat Ecrire2Chiffres(CInt(Fix(partieDecimale * 100)), LePays) AjouteResultat "cents" End If Else milliers = Array("thousandth", "millionth", "billionth") 'with the imprecision of floating point numbers, 1234562.789 - 1234562 gives 0.78900000010617077 so we need to count the number of decimal places of the original number and round the result of the subtraction Dim morceaux() As String morceaux = Split(CStr(Nombre), ",") 'by default ToString rounds to 10^-8, format G25 requires writing 25 characters if present, (at worst) 15 before the comma, the comma and 9 after, split allows to cut the resulting string If UBound(morceaux) = 1 Then 'there is a decimal part AjouteResultat "and" Dim lenghtPartieDecimale As Integer lenghtPartieDecimale = Len(morceaux(1)) If lenghtPartieDecimale > 9 Then lenghtPartieDecimale = 9 'we limit to 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 cents do not take an "s" as there is a thousandth after 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 'Writes the numbers from 0 to 999 Private Function Ecrit3Chiffres(ByVal Nombre As Integer, ByVal LePays As Pays, RegleDuCent As Boolean) As String If Nombre = 100 Then Ecrit3Chiffres = "hundred" 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 'Hundred takes an "s" when it is multiplied and not followed by a word, like the case of 100 is already dealt with we are facing a multiple If RegleDuCent = True Then Ecrit3Chiffres = jusqueSeize(centaine) & " hundreds" Else 'for 400,000 for example hundred does not take an "s" Ecrit3Chiffres = jusqueSeize(centaine) & " hundred" End If Exit Function End If If centaine = 1 Then Ecrit3Chiffres = "hundred " & Ecrire2Chiffres(reste, LePays) 'we do not say one hundred X, but hundred X Exit Function End If Ecrit3Chiffres = jusqueSeize(centaine) & " hundred " & Ecrire2Chiffres(reste, LePays) End Function 'Writes the numbers from 0 to 99 Private Function Ecrire2Chiffres(ByVal Nombre As Integer, ByVal LePays As Pays) As String If LePays <> Pays.France Then dizaines(7) = "seventy" dizaines(9) = "ninety" End If If LePays = Pays.Suisse Then dizaines(8) = "eighty" End If If Nombre < 17 Then Ecrire2Chiffres = jusqueSeize(Nombre) Exit Function End If Select Case Nombre 'special cases of 71, 80 and 81 Case 71 'in France 71 takes an and If LePays = Pays.France Then Ecrire2Chiffres = "sixty and eleven" Exit Function End If Case 80 'in France and Belgium twenty takes an "s" If LePays = Pays.Suisse Then Ecrire2Chiffres = dizaines(8) Exit Function Else Ecrire2Chiffres = dizaines(8) & "s" Exit Function End If Case 81 'in France and Belgium there is no and If LePays <> Pays.Suisse Then Ecrire2Chiffres = dizaines(8) & "-one" 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 & " and one" Case 17, 18, 19 'for 77 to 79 and 97 to 99 unite = unite Mod 10 Ecrire2Chiffres = laDizaine & "-ten-" & jusqueSeize(unite) Case Else Ecrire2Chiffres = laDizaine & "-" & jusqueSeize(unite) End Select End Function 'Adds a value to the 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 'adds a value to the 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 

 'test code 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) 'this number is too large ActiveSheet.Range("A7") = ToLettres(0.12345678961) 'there are too many digits behind the comma, the result will be rounded ActiveSheet.Range("A8") = ToLettres(6795432.456, Belgium, Euro) 'for options, we can put "keywords" ActiveSheet.Range("A9") = ToLettres(400400400, 0, 0) 'for options, we can put the corresponding numbers to the "keywords" ActiveSheet.Range("A10") = ToLettres(0.4) End Sub