Conversion Nombre en Lettre

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 'tableau qui scinde la partie entière en morceaux de 3 chiffres



'Fonction écrivant le nombre en lettres
'Nombre est le nombre à écrire
'LePays est le pays d'utilisation, pour spécificitées régionnales. Il s'agit d'un énumérable définit plus haut, les valeurs possiblis sont:
' France ou 0
' Belgique ou 1
' Suisse ou 2
'LaDevise la devise à utliser le cas échéant. Les valeurs possibles sont:
' Aucune ou 0
' Euro ou 1
' FrancSuisse ou 2
' Dollar ou 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 'j'utilise un long pour la partie entière et c'est la valeur maximun
        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 'on dit 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")

        'avec l'imprécision des nombres à virgules flotantes,  1234562.789 - 1234562 donne 0.78900000010617077 il faut donc compter le nombre de chiffres décimaux du nombre original et arrondir le resultat de la soustraction
        Dim morceaux() As String
        morceaux = Split(CStr(Nombre), ",") 'par défaut ToString arrondi à 10^-8, le format G25 oblige à écrire 25 caractères s'ils sont présents soit (au pire) 15 avant la virgule, la virgule et 9 après, split permet de découper le string obtenu

        If UBound(morceaux) = 1 Then 'il y a une partie décimale
            AjouteResultat "et"

            Dim lenghtPartieDecimale As Integer
            lenghtPartieDecimale = Len(morceaux(1))
            
            If lenghtPartieDecimale > 9 Then
                lenghtPartieDecimale = 9 'on se limite à 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 quand il est multiplié et non suivi d'un mot, comme le cas de 100 est déjà traité on est face à un multiple
        If RegleDuCent = True Then
            Ecrit3Chiffres = jusqueSeize(centaine) & " cents"
        Else 'pour 400 000 par exemple cent ne prend pas le s
            Ecrit3Chiffres = jusqueSeize(centaine) & " cent"
        End If
        Exit Function
    End If

    If centaine = 1 Then
        Ecrit3Chiffres = "cent " & Ecrire2Chiffres(reste, LePays) 'on ne dit pas un cent X, mais 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 France 71 prend un et
            If LePays = Pays.France Then
                Ecrire2Chiffres = "soixante et onze"
                Exit Function
            End If

        Case 80 'en France et Belgique le vingt 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 'pour 77 à 79 et 97 à 99
            unite = unite Mod 10
            Ecrire2Chiffres = laDizaine & "-dix-" & jusqueSeize(unite)

        Case Else
            Ecrire2Chiffres = laDizaine & "-" & jusqueSeize(unite)
    End Select
End Function

'Ajoute une valeur au 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 au 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 test
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)    'ce nombre est trop grand
        ActiveSheet.Range("A7") = ToLettres(0.12345678961)  'il y a trop de chiffres dérrière la virgule, le resultat sera arrondi
        ActiveSheet.Range("A8") = ToLettres(6795432.456, Belgique, Euro) 'pour les options, on peut mettre les "mots clés"
        ActiveSheet.Range("A9") = ToLettres(400400400, 0, 0) 'pour les options, on peut mettre les chiffres correspondants aux "mots clés"
        ActiveSheet.Range("A10") = ToLettres(0.4)
        
End Sub