Microsoft 365 conversion chiffres en lettres qui m'enlève toujours 5

Créer une discussion
Répondre

Boostez vos compétences Excel avec notre communauté !

Rejoignez Excel Downloads, le rendez-vous des passionnés où l'entraide fait la force. Apprenez, échangez, progressez – et tout ça gratuitement ! 👉 Inscrivez-vous maintenant !

S'inscrire
Usine à gaz

Usine à gaz

XLDnaute Barbatruc
Supporter XLD
Bonjour à toutes et à tous,
Je vous souhaite une belle journée 🙂

Je me tourne une nouvelle fois vers nos ténors.
J'ai un code pour convertir les chiffres en lettres.
Il semble fonctionner normalement mais il m'enlève toujours 5 et je n'arrive pas à trouver ou modifier le code :
VB: 
Function NumText(Nombre As Currency, Optional Unité As String, Optional no_chiffres As Integer, Optional SousUnité As String) As String
Dim PartieEntière As Currency, PartieDécimal As Currency
Dim TxtEntier As String, TxtDécimal As String
PartieEntière = Int(Nombre)
TxtEntier = NumTextEntier(PartieEntière)
If no_chiffres > 0 Then
    PartieDécimal = (Nombre - PartieEntière) * 10 ^ no_chiffres
    TxtDécimal = Format(PartieDécimal, String(no_chiffres, "0"))
End If
NumText = TxtEntier & Unité & " " & TxtDécimal & " " & SousUnité
End Function

Function NumTextEntier(ByVal Entier As Currency) As String
Dim no_Classe As Integer, Classe As Integer
If Entier = 0 Then
    NumTextEntier = "Zéro "
Else
    While Entier > 0
        Classe = Entier - Int(Entier / 1005) * 1005
        NumTextEntier = TxtClasse(Classe, no_Classe) & NumTextEntier
        no_Classe = no_Classe + 1
        Entier = Int(Entier / 1005)
    Wend
End If
End Function

Function TxtClasse(Classe As Integer, no_Classe As Integer) As String
Dim Centaine As Integer, Dizaine As Integer, Unité As Integer, Unités2Chiffres As Integer
Dim TxtCentaines As String, TxtDizaines As String, TxtUnités As String
Dim TClasses As Variant, Tdizaines As Variant, TUnités As Variant
TClasses = Array("", "mille", "million", "milliard", "billion")
Tdizaines = Array("", "", "vingt", "trente", "quarante", "cinquante", "soixante", "soixante", "quatre vingt", "quatre vingt")
TUnités = Array("", "un", "deux", "trois", "quatre", "cinq", "six", "sept", "huit", "neuf", _
"dix", "onze", "douze", "treize", "quatorze", "quinze", "seize", "dix sept", "dix huit", "dix neuf")
   If Classe = 0 Then Exit Function
    ' Pas de un pour mille
    If Classe = 1 And no_Classe = 1 Then
        TxtClasse = "mille "
        Exit Function
    End If
    '
    Centaine = Classe \ 100
    Unités2Chiffres = Classe Mod 100
    Dizaine = Unités2Chiffres \ 10
    Unité = Unités2Chiffres Mod 10
    ' Les centaines -----
    If Centaine = 1 Then
            TxtCentaines = "cent "
    ElseIf Centaine > 1 Then
            TxtCentaines = TUnités(Centaine) & " cent" & IIf(Unités2Chiffres > 0, " ", "s ")
    End If
    ' Les dizaines ------
    TxtDizaines = Tdizaines(Dizaine)
    If Unité = 1 And Dizaine > 1 And Dizaine < 8 Then
        TxtDizaines = TxtDizaines & " et"
    End If
    If Dizaine = 1 Or Dizaine = 7 Or Dizaine = 9 Then
        Unité = Unité + 10: Dizaine = 0
    End If
    TxtDizaines = TxtDizaines & IIf(Unités2Chiffres = 80, "s", "")
    If Unités2Chiffres > 19 And Unité > 0 Then
            TxtDizaines = TxtDizaines & " "
    ElseIf Dizaine > 0 Then
            TxtDizaines = TxtDizaines & " "
    End If
    ' Les unités -------- Espace si unité > 0
    TxtUnités = TUnités(Unité) & IIf(Unité > 0, " ", "")
    ' La classe --------- un s sauf pour mille
    TxtClasse = TClasses(no_Classe) & IIf(no_Classe > 1 And Classe > 1, "s", "") & IIf(no_Classe > 0, " ", "")
    ' Résultat ----------
    TxtClasse = TxtCentaines & TxtDizaines & TxtUnités & TxtClasse
End Function
Pourriez-vous m'aider ?
Je joins un fichier test et je continue à chercher.

je vous remercie,
Amicalement,
lionel,
 

Pièces jointes

Dernière édition:
Trier par date Trier par votes
je l'ai encore amélioré il accepte tout les orthographes maintenant
il accepte
bla-bla-bla euro et bla-bla-bla centimes
bla bla bla euro bla bla bla centimes
bla bla bla virgule bla bla bla centimes
bla bla bla , bla bla bla centimes
bla bla bla euro
bla bla bla euros
bla bla bla virgule bla bla bla centimes

avec ou sans les "s" selon la normes
bla bla blas euro bla bla blas
bla bla blas euros bla bla blas

bref pour le coup je suis allé encore plus loin que prévu
pour le coup c'est toi qui en a le primeur il n'est pas encore dispo dans les ressources
VB: 
'*************************************
'nombre lettre to nombre en numerique
'auteur :patricktoulon
'version1.2 17/06/2019
' en cours de developpements
'version finale 1.3 29/11/2021
'mise ajour
'ajout de la prise en charge des centimes 29/11/2021
'************************************
Option Explicit
Sub test()
    MsgBox NblettreToNum("sept-cent-trente-huit Euros et  dix-huit")
End Sub

Function NblettreToNum(chaine As String)
    Dim Lettres, chiffre, tranche, tranchenum, x, z&, i&, a&, t, q&, tc, StringOper, calcul
    Lettres = Array("zero", "un", "deux", "trois", "quatre", "cinq", "six", "sept", "huit", "neuf", "dix", "onze", "douze", _
                    "treize", "quatorze", "quinze", "seize", "dix-sept", "dix-huit", "dix-neuf", "vingt", "trente", "quarante", "cinquante", _
                    "soixante", "soixante dix", "quatrevingt", "quatrevingtdix", "cent", "cents")
    chiffre = Array(0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 30, 40, 50, 60, 70, 80, 90, 100, 100)

    tranche = Array("mille", "million", "milliard")
    tranchenum = Array("*1000" & vbCrLf, "*1000000" & vbCrLf, "*1000000000" & vbCrLf)
    x = Application.Trim(LCase(chaine))
    'nettoyage grammatical FR
    For i = 4 To UBound(Lettres): x = Replace(x, Lettres(i) & "s", Lettres(i)): Next 'pour les "s" des nombres en lettres
    x = Replace(x, "euros", "euro")
    x = Replace(x, "euro et", ",")
    If Right(x, 4) = "euro" Then x = Replace(x, "euro", "")
    If Mid(x, InStr(1, x, "euro") + 2) <> "" Then x = Replace(x, "euro", ",") 'pour le "euro sans le "et"
    x = Replace(Replace(x, "virgule", ","), "virgule", ",")
    x = Replace(Replace(Replace(x, " et ", " "), "d'", " "), "euro", "")
     x = Replace(x, "-", " ")
    x = Replace(Replace(x, "quatre vingts", "quatrevingt"), "quatre vingt", "quatrevingt") 'cas particulier de quatr vingt(s)
    x = Replace(Replace(x, "centimes", ""), "centime", "")
    For i = 0 To UBound(tranche): x = Replace(x, tranche(i), tranchenum(i)): Next
    x = Split(Application.Trim(x), ",")


    For z = 0 To UBound(x)
        'on a les tranches
        t = Split(x(z), vbCrLf)
        For i = 0 To UBound(t)
            tc = Split(Application.Trim(t(i)), " ")
            For a = 0 To UBound(tc)
                If tc(0) = "cent" Then tc(a) = 100
                If InStr(1, tc(a), "cent") = 0 Then
                    q = Application.IfError(Application.Match(tc(a), Lettres, 0), 0)
                    If q > 0 Then tc(a) = IIf(a > 0, "+", "") & chiffre(q - 1)
                Else
                    tc(a - 1) = Val(tc(a - 1)) * 100: tc(a) = ""
                End If
            Next
            t(i) = Join(tc)
            If InStr(1, t(i), "*") > 0 Then t(i) = "(" & Replace(t(i), "*", ")*")
            t(i) = "(" & t(i) & ")"
        Next
        StringOper = Replace(Replace(Join(t, "+"), "+()", ""), "()*", "")
        calcul = calcul + IIf(z = 1, Evaluate(StringOper) / 100, Evaluate(StringOper))
        Debug.Print chaine & vbCrLf; "l'operation " & IIf(z = 0, "entier", "centime") & vbCrLf & StringOper & vbCrLf & "Résultat " & calcul
        StringOper = ""
    Next
    Debug.Print "**********************************"
    NblettreToNum = calcul
End Function

démonstration
demo.gif
 
Vote positif 0 Vote négatif
Ah!! bonjour M12
en voilà un idée
je pense qu'au lieu de triturer la chaîne a chercher si tranche ou pas tranche j'ajouterais zéro virgule moi perso " soit / 100
j'essai d'intégrer ça et je reviens
allez 30 seconde de réflexion 1 seule ligne de code en plus et voilà

demo.gif


LOL!!!
VB: 
'*************************************
'nombre lettre to nombre en numerique
'auteur :patricktoulon
'version1.2 17/06/2019
' en cours de developpements
'version finale 1.3 29/11/2021
'mise ajour
'ajout de la prise en charge des centimes 29/11/2021
'************************************
Option Explicit
Sub test()
    MsgBox NblettreToNum("sept-cent-trente-huit Euros et  dix-huit")
End Sub

Function NblettreToNum(chaine As String)
    Dim Lettres, chiffre, tranche, tranchenum, x, z&, i&, a&, t, q&, tc, StringOper, calcul, divi&
    Lettres = Array("zero", "un", "deux", "trois", "quatre", "cinq", "six", "sept", "huit", "neuf", "dix", "onze", "douze", _
                    "treize", "quatorze", "quinze", "seize", "dix-sept", "dix-huit", "dix-neuf", "vingt", "trente", "quarante", "cinquante", _
                    "soixante", "soixante dix", "quatrevingt", "quatrevingtdix", "cent", "cents")
    chiffre = Array(0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 30, 40, 50, 60, 70, 80, 90, 100, 100)

    tranche = Array("mille", "million", "milliard")
    tranchenum = Array("*1000" & vbCrLf, "*1000000" & vbCrLf, "*1000000000" & vbCrLf)
    x = Application.Trim(LCase(chaine))
    If x Like "*centime*" And Not x Like "*euro*" Then divi = 100
    'nettoyage grammatical FR
    For i = 4 To UBound(Lettres): x = Replace(x, Lettres(i) & "s", Lettres(i)): Next 'pour les "s" des nombres en lettres
    x = Replace(x, "euros", "euro")
    x = Replace(x, "euro et", ",")
    If Right(x, 4) = "euro" Then x = Replace(x, "euro", "")
    If Mid(x, InStr(1, x, "euro") + 2) <> "" Then x = Replace(x, "euro", ",") 'pour le "euro sans le "et"
    x = Replace(Replace(x, "virgule", ","), "virgule", ",")
    x = Replace(Replace(Replace(x, " et ", " "), "d'", " "), "euro", "")
     x = Replace(x, "-", " ")
    x = Replace(Replace(x, "quatre vingts", "quatrevingt"), "quatre vingt", "quatrevingt") 'cas particulier de quatr vingt(s)
    x = Replace(Replace(x, "centimes", ""), "centime", "")
    For i = 0 To UBound(tranche): x = Replace(x, tranche(i), tranchenum(i)): Next
    x = Split(Application.Trim(x), ",")


    For z = 0 To UBound(x)
        'on a les tranches
        t = Split(x(z), vbCrLf)
        For i = 0 To UBound(t)
            tc = Split(Application.Trim(t(i)), " ")
            For a = 0 To UBound(tc)
                If tc(0) = "cent" Then tc(a) = 100
                If InStr(1, tc(a), "cent") = 0 Then
                    q = Application.IfError(Application.Match(tc(a), Lettres, 0), 0)
                    If q > 0 Then tc(a) = IIf(a > 0, "+", "") & chiffre(q - 1)
                Else
                    tc(a - 1) = Val(tc(a - 1)) * 100: tc(a) = ""
                End If
            Next
            t(i) = Join(tc)
            If InStr(1, t(i), "*") > 0 Then t(i) = "(" & Replace(t(i), "*", ")*")
            t(i) = "(" & t(i) & ")"
        Next
        StringOper = Replace(Replace(Join(t, "+"), "+()", ""), "()*", "")
        calcul = calcul + IIf(z = 1, Evaluate(StringOper) / 100, Evaluate(StringOper))
        Debug.Print chaine & vbCrLf; "l'operation " & IIf(z = 0, "entier", "centime") & vbCrLf & StringOper & vbCrLf & "Résultat " & calcul
        StringOper = ""
    Next
    Debug.Print "**********************************"
    If divi = 100 Then calcul = calcul / 100
    NblettreToNum = calcul
End Function
 
Vote positif 0 Vote négatif
re
et voilà pour @Phil69970 avec "€uro"
Merci M12

VB: 
Function NblettreToNum(chaine As String)
    Dim Lettres, chiffre, tranche, tranchenum, x, z&, i&, a&, t, q&, tc, StringOper, calcul, divi&
    Lettres = Array("zero", "un", "deux", "trois", "quatre", "cinq", "six", "sept", "huit", "neuf", "dix", "onze", "douze", _
                    "treize", "quatorze", "quinze", "seize", "dix-sept", "dix-huit", "dix-neuf", "vingt", "trente", "quarante", "cinquante", _
                    "soixante", "soixante dix", "quatrevingt", "quatrevingtdix", "cent", "cents")
    chiffre = Array(0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 30, 40, 50, 60, 70, 80, 90, 100, 100)

    tranche = Array("mille", "million", "milliard")
    tranchenum = Array("*1000" & vbCrLf, "*1000000" & vbCrLf, "*1000000000" & vbCrLf)
    x = Application.Trim(LCase(chaine))
     'nettoyage grammatical FR
    For i = 4 To UBound(Lettres): x = Replace(x, Lettres(i) & "s", Lettres(i)): Next 'pour les "s" des nombres en lettres
    x = Replace(x, "€uro", "euro")
   x = Replace(x, "euros", "euro")
     
    If x Like "*centime*" And Not x Like "*euro*" Then divi = 100
   x = Replace(x, "euro et", ",")
    If Right(x, 4) = "euro" Then x = Replace(x, "euro", "")
    If Mid(x, InStr(1, x, "euro") + 2) <> "" Then x = Replace(x, "euro", ",") 'pour le "euro sans le "et"
    x = Replace(Replace(x, "virgule", ","), "virgule", ",")
    x = Replace(Replace(Replace(x, " et ", " "), "d'", " "), "euro", "")
     x = Replace(x, "-", " ")
    x = Replace(Replace(x, "quatre vingts", "quatrevingt"), "quatre vingt", "quatrevingt") 'cas particulier de quatr vingt(s)
    x = Replace(Replace(x, "centimes", ""), "centime", "")
    For i = 0 To UBound(tranche): x = Replace(x, tranche(i), tranchenum(i)): Next
    x = Split(Application.Trim(x), ",")


    For z = 0 To UBound(x)
        'on a les tranches
        t = Split(x(z), vbCrLf)
        For i = 0 To UBound(t)
            tc = Split(Application.Trim(t(i)), " ")
            For a = 0 To UBound(tc)
                If tc(0) = "cent" Then tc(0) = 100
                If InStr(1, tc(a), "cent") = 0 Then
                    q = Application.IfError(Application.Match(tc(a), Lettres, 0), 0)
                    If q > 0 Then tc(a) = IIf(a > 0, "+", "") & chiffre(q - 1)
                Else
                    tc(a - 1) = Val(tc(a - 1)) * 100: tc(a) = ""
                End If
            Next
            t(i) = Join(tc)
            If InStr(1, t(i), "*") > 0 Then t(i) = "(" & Replace(t(i), "*", ")*")
            t(i) = "(" & t(i) & ")"
        Next
        StringOper = Replace(Replace(Join(t, "+"), "+()", ""), "()*", "")
        calcul = calcul + IIf(z = 1, Evaluate(StringOper) / 100, Evaluate(StringOper))
        Debug.Print chaine & vbCrLf; "l'operation " & IIf(z = 0, "entier", "centime") & vbCrLf & StringOper & vbCrLf & "Résultat " & calcul
        StringOper = ""
    Next
    Debug.Print "**********************************"
    If divi = 100 Then calcul = calcul / 100
    NblettreToNum = calcul
End Function

n
 
Dernière édition:
Vote positif 0 Vote négatif
je cite ton titre
conversion lettres en chiffres qui m'enlève toujours 5

je t'ai répondu en fonctionne de ça

Mais si tu veux l'inverse
voila en FR
www.excel-downloads.com

nombre en toutes lettre FR diverse monnaies et autres - Mises à jour

www.excel-downloads.com www.excel-downloads.com

et voilà en US
www.excel-downloads.com

nombre en toute lettres Version US

patricktoulon a posté une nouvelle ressource : nombre en toute lettres Version US - ecrire un de nombre en lettre pour faire suite à la version française voici aujourd'hui la version US de ma fonction nblettre2020 tout est expliqué dans les commentaires En savoir plus sur cette ressource...
www.excel-downloads.com www.excel-downloads.com
Mr est servi 😁
 
Vote positif 0 Vote négatif
Re-Patrick 🙂
Dans mon #post1 j'avais précisé: J'ai un code pour convertir les lettres en chiffres.
et je me suis trompé c'est l'inverse lol
Je te remercie pour tout ce que tu as fait mais je ne peux pas m'en servir malheureusement.
lionel 🙂
 
Vote positif 0 Vote négatif
???????🤔🤔🤔
en plus je viens de m’apercevoir que ton code départ c'est mon code qui a été très très très maladroitement touché par je ne sais qui
je lui tordrais bien le coup a celui là
prend ma fonction entière dans les source et tu n'aura pas besoins des deux autres fonctions intermédiaires
ma fonction gère tout
donne moi le nom et le matricule de celui qui t'a donné le code de départ 😂😂😂😂
ferais mieux de faire du tricot celui là
 
Vote positif 0 Vote négatif
tiens si tu prends la 7 elle fait tout
euro, dollars ,dinar ,kowet,dinars, tunisien,courrnne ,livresterling ,kilo, gramme, litres ,mètres
VB: 
'********************************************************************************
'                      NOMBRE EN LETTRE version Francaise                       *
'auteur: patricktoulon sur exceldownload                                        *
'version 1.0 à 6.3 supprimées                                                   *
'version 7.0                                                                    *
'Date version 15 novembre 2020------------------------                          *
'refonte complete du moteur de convertion (simplifié dans un select case)       *
'Ajout  du moteur d'association a une mesure(monnaie ou autre)                  *
'merge des modeles nombre et monnaie en une seule fonction                      *
'sans association ou monnaie ou mesure concernée 3 chiffres après la virgule    *
'on va toujours jusqu'a 999 deciliards (9999.....) EN STRING!!!!!               *
'on va jusqu'au billion en formule et en long en VBA                            *
'because vba et excel abrege les nombre au delas!!!!                            *
'                                                                               *
'                <<<monnaie et mesure deja intégrées>>>                         *
'                                                                               *
'sans mesure        (3 chiffres après la virgule presents ou pas)(pas d'arrondi)*
'EURO               (2 chiffres après la virgule)(pas d'arrondi)                *
'DOLLAR             (2 chiffres après la virgule)(pas d'arrondi)                *
'dinar koweiti      (3 chiffres après la virgule)(pas d'arrondi)                *
'dinar tunisien     (3 chiffres après la virgule)(pas d'arrondi)                *
'dirham marocain    (2 chiffres après la virgule)(pas d'arrondi)                *
'kilo               (3 chiffres après la virgule)(pas d'arrondi)                *
'                                                                               *
'mise a jour 26/10/2020-------------------------                                *
'ajout du choix de l'arrondi 3 eme argument 4 choix possibles (-1,0,1,2)        *
'-1 ou pas d'argument =pas d'arrondi (par defaut si omis)                       *
'0=arrondi inferieur (RoundDown)                                                *
'1=arrondi automatique (round)                                                  *
'2=arrondi superieur(RoundUp)                                                   *
'                                                                               *
'mise a jour 27/10/2020--------------------------                               *
'Ajout de la monnaie suedoise "le couronne" (demande de @Jouxte)(XLD)           *
'                                                                               *
'mise a jour 27/10/2020--------------------------                               *
'refonte du moteur d'arrondi simplifié                                          *
'néanmoins un bug reside dans le multiple de 1 pour l'entier vallant 1          *
'avec l'arrondi vba,superieur,inférieur                                         *
'                                                                               *
'mise a jour 28/10/2020---------------------------                              *
'correction du bug de l'arrondi en bloquant l'arrondi en dessous 1.10(inutile)  *
'                                                                               *
'                                                                               *
'*********************************************************************************************************
'                                   exemples d'appel de la fonction                                       *
'                                                                                                        *
'Debug.Print NblettreFR2020( [nombre] , [monnaie ou nombre de decimal] , [mode d'arrondi] )              *
'Debug.Print NblettreFR2020( [nombre] )             '2 decimales automatique  pas d'arrondi              *
'Debug.Print NblettreFR2020( [nombre],[2 ou 3] )    '2 ou 3 decimales pas d'arrondi                      *
'Debug.Print NblettreFR2020([nombre], decRound:=2)  '2 decimales forcées arrondi au 10eme superieur      *
'Debug.Print NblettreFR2020([nombre], ,2)           '2 decimales forcées arrondi au 10eme superieur      *
'Debug.Print NblettreFR2020([nombre],2 )            '2 decimales forcées et pas d'arrondi                *
'Debug.Print NblettreFR2020([nombre],3,2 )          '3 decimales forcées arrondi au 10eme superieur      *
'Debug.Print NblettreFR2020([nombre],3,1 )          '3 decimales forcées arrondi automatique VBA         *
'Debug.Print NblettreFR2020([nombre],3,0 )          '3 decimales forcées arrondi au 10eme inférieur      *
'                                                                                                        *
'*********************************************************************************************************
'****************************************************************************************************************
'                                   exemple d'utilisation en formule                                            *
'                                                                                                               *
'                                            à 2 decimales                                                      *
'=NblettreFR2020(A1,2,)     'lecture tel quel 2 decimales considérées(la 3eme est occulté si presente)          *
'=NblettreFR2020(A1,2,0)    'arrondi inférieur 2 decimales considérées(la 3eme est occulté si presente)         *
'=NblettreFR2020(A1,2,1)    'arrondi automatique 2 decimales considérées(la 3eme est occulté si presente)(+/-5) *
'=NblettreFR2020(A1,2,2)    'arrondi supérieur 2 decimales considérées(la 3eme est occulté si presente)         *
'                                                                                                               *
'                                             à 3 decimales                                                     *
'si moins de 3 elle sont ajoutées"#00"(reconsidération de l'echelle de la tranche)                              *
'=NblettreFR2020(A1,3,))    'lecture tel quel 3 decimales considérées                                           *
'=NblettreFR2020(A1,3,0))   'arrondi inférieur 3 decimales considérées                                          *
'=NblettreFR2020(A1,3,1))   'arrondi automatique 3 decimales considérées (+/-5)                                 *
'=NblettreFR2020(A1,3,2))   'arrondi supérieur 3 decimales considérées                                          *
'                                                                                                               *
'                                                                                                               *
'                                           avec les monnaies                                                   *
'                                                                                                               *
'=NblettreFR2020($A2;"Couronne")    'monnaie couronne 2 decimales       (couronne/öre)(féminin)                 *
'=NblettreFR2020($A2;"dinark")      'monnaie dinar kuweiti 3 decimales  (dinar/fil)                             *
'=NblettreFR2020($A2;"dinar")       'monnaie dinar  3 decimales         (dinar/millime)                         *
'=NblettreFR2020($A2;"Dollar")      'monnaie US 2 decimales             (dollar/cent)                           *
'=NblettreFR2020($A2;"euro")        'monnaie europe 2 decimales         (euro/centime)                          *
'=NblettreFR2020($A2;"£")ou"Ls"     'monnaie Livre Sterling 2 decimales (livre sterling/(peny/pence))           *
'=NblettreFR2020($A2;"dirhammarocain") 'monnaie marocaine 2 decimales   (dirham/rial)                           *
'                                                                                                               *
'                                                                                                               *
'                                           D'autres mesures                                                    *
'                                                                                                               *
'=NblettreFR2020($A2;"kilo")        'poids   3 decimales         (kilo/gramme)                                  *
'                                                                                                               *
'                                                                                                               *
'                                   d'autre a venir à la demande :)                                             *
'****************************************************************************************************************


Option Explicit
Sub test()
    NblettreFR2020 1000000
    NblettreFR2020 1000000.767, 3, 2
    NblettreFR2020 1.01, 2, 2

End Sub
Sub testj()
    NblettreFR2020 0.75
End Sub

Public Function NblettreFR2020(chain As String, Optional MonnaieOuNombreDeDecimale As String = "", Optional decRound As Long = -1) As String
    Dim t, p&, q$, cent$, cx&, d$, u$, Part, ms, Ul, Diz, I&, et$, centime, w$, x&, z, z1, texte, prefixe$, pluriel$, AvecCent$, fric, dec
    Ul = Array("", "un", "deux", "trois", "quatre", "cinq", "six", "sept", "huit", "neuf", "dix", "onze", "douze", "treize", "quatorze", "quinze", "seize", "dix-sept", "dix-huit", "dix-neuf")
    Diz = Array("", "dix", "vingt", "trente", "quarante", "cinquante", "soixante", "soixante-dix", "quatre-vingt", "quatre-vingt-dix", "cent")
    ms = Array("", " decilliard", " decillion", " nonilliard", " nonillion", " octillard", " octillion", " septilliard", " septillion", " sextilliard", " sextillion", " quintilliard ", " Quintillion", " quadrilliard", " quadrillion", " trilliard", " trillion", " Billiard", " billion", " milliard", " million", " mille", "")
    chain = Replace(chain, ".", ",")    'au cas ou
    If Not IsNumeric(chain) Then NblettreFR2020 = "Invalid Chain!!!": Exit Function
    Part = Split(chain, ","): If Len(Part(0)) > 66 Then NblettreFR2020 = "OutOFF(CAR*66)!!": Exit Function
    fric = MonnaieOuNombreDeDecimale
    '--------------------------------------------------------------------------------------------
    'moteur d'association
    Select Case LCase(fric)
    Case "", 2: fric = IIf(UBound(Part) > 0, "virgule", ""): centime = "": cx = 2: pluriel = ""
    Case 3: fric = IIf(UBound(Part) > 0, "virgule", ""): centime = "": cx = 3: pluriel = ""
    Case "euro": centime = "centime": cx = 2: prefixe = "d'": AvecCent = " et":: pluriel = "s":    ' decRound = -1
    Case "dollar": centime = "cent": cx = 2: prefixe = "de ": pluriel = "s": AvecCent = " et":    ' decRound = -1
    Case "dinark", "dinar": decRound = -1: centime = IIf(fric = "dinark", "fil", "millime"): fric = "dinar": cx = 3: prefixe = "de ": pluriel = "s": AvecCent = " et"
    Case "kilo": decRound = -1: centime = "gramme": cx = 3: prefixe = "de ": pluriel = "s": AvecCent = " et"
    Case "dirhammarocain": fric = "dirham": centime = "rial": cx = 2: pluriel = "s": AvecCent = " et": prefixe = "de "
    Case "£": fric = "Livre Sterling": prefixe = "of ": AvecCent = " et ": pluriel = "": cx = 2: If UBound(Part) > 0 Then If Part(1) > 1 Then centime = "pence" Else centime = "peny"
    Case "couronne": centime = "Öre": cx = 2: prefixe = "de ": AvecCent = " et":: pluriel = "": fric = IIf(Part(0) > 1, fric & "s", fric)
        '......
        '.....
    End Select
    '--------------------------------------------------------------------------------------------
    'Moteur de l'arrondi
    If CDbl(chain) < 1.1 Then decRound = -1    '(inutile de descendre en dessous)
    If decRound <> -1 Then
        Select Case decRound
        Case 0: chain = WorksheetFunction.RoundDown(chain, cx - 1):
        Case 1: chain = WorksheetFunction.Round(chain, cx - 1):
        Case 2: chain = WorksheetFunction.RoundUp(chain, cx - 1):
        End Select
        Part = Split(chain, ",")
    End If
    If UBound(Part) > 0 Then Part(1) = Left(Part(1), cx)
    '--------------------------------------------------------------------------------------------


    fric = IIf(Val(Part(0)) > 999000 And Val(Right(Part(0), 6)) = 0, prefixe & fric, fric)    'ajout du prefixe a partir de 1 million si mod 10
    fric = IIf(Part(0) > 1, fric & pluriel, fric) & IIf(UBound(Part) > 0, AvecCent, "")
    If UBound(Part) > 0 Then Part(1) = Left(Part(1), cx): centime = IIf(Part(1) > 1 And centime <> "", centime & pluriel, centime)


    If Val(Part(0)) = 0 Then NblettreFR2020 = "zero" & fric
    For I = 0 To UBound(Part)
        If I = 0 Then
            t = Split(Trim(Format(Part(I), Application.Rept(" @@@", (Len(Part(I)) / 3) + 1))), " ")
        Else
            t = Array(CStr(Left(Part(1) & "00", cx)))
        End If
        cent = "": d = "": u = ""
        For p = UBound(t) To 0 Step -1
            '--------------------------------------------------------------------------------------------
            'Moteur de conversion
            cent = "": d = "": u = "": z1 = t(p): z = t(p)
            If z >= 100 Then cent = IIf(Left(z, 1) > 1, Ul(Left(z, 1)) & " cent", "cent")
            If z Mod 100 = 0 And z > 100 Then cent = cent & "s" Else cent = cent & " "

            z = Right(z1, 2)

            Select Case True
            Case z < 20: d = "": u = Ul(z)    'si en dessous de 20 on passe directement par l'array ul
            Case z > 70 And z < 80: et = IIf(Right(z, 1) = 1, " et ", "-"): d = Diz(Left(z, 1) - 1): u = et & Ul(Right(z, 1) + 10)    'de 71 a 79 c'est dizaine-1 et unité+10 pour 71 et =" et " sinon et="-"
            Case z = 80: d = Diz(Left(z, 1)) & "s"    'exeption seul le 80 tout seul prends le "s"
            Case z > 90: d = Diz(Left(z, 1) - 1): u = "-" & Ul(Right(z, 1) + 10)    'de 91 a 99 c'est dizaine-1 et unité+10 le et est automatiquement "-"
                'pour tout le reste c'est dizaine et unité
            Case Else: et = IIf(Right(z, 1) = "0" Or z < 10, "", IIf(Right(z, 1) = 1, "-et-", "-")): d = Diz(Left(z, 1)): u = et & Ul(Right(z, 1))    'If Right(z, 1) = "0" Or z < 10 Then et = "" Else et = "-"
            End Select
            'fin de conversion
            '--------------------------------------------------------------------------------------------
            'compile du segment
            t(p) = Trim(cent & d & u) & " " & IIf(I = 0, IIf(z1 > 0, ms(UBound(ms) - x) & IIf(z1 > 1, IIf(x > 1, "s ", " "), " "), " "), " ")
            x = x + 1    'itération pour soustraire index de "ms"
            If t(p) = "un  mille " Then t(p) = "mille "
            If t(p) = "  " And Val(Part(I)) = 0 Then t(p) = "Zéro"
            'Debug.Print t(p)
        Next
        If I = 0 Then q = fric Else q = centime    'association mesure accordée
        texte = texte & Application.Trim(Join(t, "")) & " " & q & " "
    Next

    '------------------------------------------------------------------------
    'correctif féminin/masculin( pour l'unité de fric et centime) si besoins pour certaines monnaies
    Select Case True
    Case InStr(1, LCase(texte), "couronne", vbTextCompare) > 0: texte = Replace(texte, "un Couronne", "une Couronne")
        'etc....
    End Select
    '------------------------------------------------------------------------
    'compilation et régularisation des espaces de la chaine finale
    texte = Application.Trim(texte): If Right(texte, 7) = "virgule" Then texte = Replace(texte, " virgule", "")
    'Debug.Print texte'juste pour voir
    texte = Trim(Replace(texte, "Zéro " & fric, ""))
    
    NblettreFR2020 = texte    'RETURN!!!
End Function
demo.gif

et je vais très loin avec
1638211439105.png

c'est pas compliqué 😉
 
Vote positif 0 Vote négatif
Rejoins nos membres "Supporter XLD" et booste ton expérience Excel !
- Navigue sans publicité
- Accède à Cléa, notre assistante IA experte Excel... et pas que...
- Profite de fonctionnalités exclusives
Ton soutien permet à Excel Downloads de rester 100% gratuit et de continuer à rassembler les passionnés d'Excel.
Je deviens Supporter XLD

Discussions similaires

G
  • Question Question
XL 2013 Conversion chiffres en lettre avec 3 chiffre après la virgule
Réponses
5
Affichages
3 K
patricktoulon
patricktoulon
G
  • Question Question
Changer les lettres avec celles qui viennent en 3eme position apres dans l'alphab
Réponses
7
Affichages
7 K
Pierrot93
Pierrot93
M
[REF] Wiki 5 de MichelXld (Formules, Audits de formules, Répertoires, Fichiers)
Réponses
0
Affichages
47 K
MichelXld
M
M
[REF] Wiki 2 de MichelXld (Ce qui touche aux UserForm)
Réponses
0
Affichages
116 K
MichelXld
M
Retour