Conversion de nombre en lettres

Bonjour tous les expert en excel.
Qui peut m’aider à résoudre le problème de règle de 80 dans le code ci dessus.
Je veux que seul le 80 = quatre-vingts avec « s »
Mais le reste comme 80 000 = quatre-vingt mille sans « s »

Option Explicit

Public Function ChLettres(Montant As Double, Optional devise As Byte = 0, Optional Langue As Byte = 0) As String

Dim partieEntiere As Variant, partieDecimale As Integer
Dim texteDevise As String, texteCentimes As String, position As Byte

If (Montant < 0) Then Montant = Abs(Montant)

partieEntiere = Int(Montant)

position = InStr(1, Montant, « , »)
If (position < 1) Then position = InStr(1, Montant, « , »)

If (position > 0) Then
position = position + 1

If devise = 0 Or devise = 4 Then
    partieDecimale = Left(Mid(Montant, position), 3)
Else
    partieDecimale = Left(Mid(Montant, position), 2)
End If

Else

partieDecimale = 0

End If

If partieDecimale = 0 Then
If partieEntiere > 999999999999999# Then
ChLettres = « # TropGrand # »
Exit Function
End If
Else
If partieEntiere > 9999999999999# Then
ChLettres = « # TropGrand # »
Exit Function
End If
End If

Select Case devise
Case 0
If partieDecimale > 0 Then texteDevise = " virgule"
Case 1
texteDevise = " Euro"
If partieDecimale > 0 Then texteCentimes = " Cents"
Case 2
texteDevise = " Dollar"
If partieDecimale > 0 Then texteCentimes = " Cent"
Case 3
’ Pour Ariary, on met virgule avant décimales et ariary à la fin
If partieDecimale > 0 Then
texteDevise = " virgule"
texteCentimes = " Ariary"
Else
texteDevise = " Ariary"
texteCentimes = «  »
End If
Case 4
texteDevise = " Dinar"
If partieDecimale = 1 Then texteCentimes = " Millime"
If partieDecimale > 1 Then texteCentimes = " Millimes"

End Select
If devise = 0 And partieEntiere = 0 Then texteDevise = « zéro » & texteDevise
If devise > 0 And partieEntiere = 0 Then texteDevise = « zéro » & texteDevise
Select Case devise
Case 1, 2, 4
If partieEntiere > 1 Then texteDevise = texteDevise & « s »
Case 3
If partieEntiere > 1 Then texteDevise = texteDevise
End Select

ChLettres = NbEnMille(CDbl(partieEntiere), Langue) & texteDevise & " " & NbEnCent(partieDecimale, Langue) & texteCentimes

End Function

Private Function NbEnMille(Nombre As Double, Langue As Byte) As String

Dim tabBloc As Variant: Dim numBloc As Byte
Dim nombreBloc As Integer, reste As Double, texteBloc As String
tabBloc = Array(«  », « mille », « million », « milliard », « billion »)
numBloc = 0
If Nombre = 0 Then Exit Function

Do While Nombre > 0
reste = Int(Nombre / 1000)
nombreBloc = Nombre - (reste * 1000)

If nombreBloc > 0 Then
    texteBloc = NbEnCent(CInt(nombreBloc), Langue)
    
    Select Case numBloc
        Case 0
            ' Rien à ajouter, c’est l’unité
        Case 1
            If nombreBloc = 1 Then
                texteBloc = "mille"
            Else
                texteBloc = texteBloc & " mille"
            End If
        Case Else
            If nombreBloc = 1 Then
                texteBloc = "un " & tabBloc(numBloc)
            Else
                texteBloc = texteBloc & " " & tabBloc(numBloc) & "s"
            End If
    End Select
    
    NbEnMille = texteBloc & " " & NbEnMille
End If

Nombre = reste
numBloc = numBloc + 1

Loop

NbEnMille = UCase(Left(NbEnMille, 1)) & Mid(NbEnMille, 2)

End Function

Private Function NbEnCent(Nombre As Integer, Langue As Byte) As String

Dim tabUnites As Variant
Dim NbCent As Byte, reste As Byte, texteReste As String

tabUnites = Array(«  », « un », « deux », « trois », « quatre », « cinq », « six », « sept », « huit », « neuf », « dix »)

NbCent = Int(Nombre / 100): reste = Nombre - (NbCent * 100)
texteReste = NbEnDizaines(reste, Langue)

Select Case NbCent
Case 0
NbEnCent = texteReste
Case 1
If reste = 0 Then
NbEnCent = « cent »
Else
NbEnCent = « cent " & texteReste
End If
Case Else
If reste = 0 Then
NbEnCent = tabUnites(NbCent) & " cents »
Else
NbEnCent = tabUnites(NbCent) & " cent " & texteReste
End If
End Select

End Function

Private Function NbEnDizaines(Nombre As Byte, Langue As Byte) As String

Dim tabUnites As Variant, tabDizaines As Variant
Dim nbUnites As Byte, nbDizaines As Byte
Dim texteLiaison As String

tabUnites = Array(«  », « un », « deux », « trois », « quatre », « cinq », « six », « sept », « huit », « neuf », « dix », « onze », « douze », « treize », « quatorze », « quinze », « seize », « dix-sept », « dix-huit », « dix-neuf »)
tabDizaines = Array(«  », «  », « vingt », « trente », « quarante », « cinquante », « soixante », « soixante », « quatre-vingt », « quatre-vingt »)

If Langue = 1 Then
tabDizaines(7) = « septante »
tabDizaines(9) = « nonante »
End If

If Langue = 2 Then tabDizaines(8) = « huitante »

nbDizaines = Int(Nombre / 10): nbUnites = Nombre - (nbDizaines * 10)
texteLiaison = « - »: If nbUnites = 1 Then texteLiaison = " et "

Select Case nbDizaines
Case 0
texteLiaison = «  »
Case 1
nbUnites = nbUnites + 10
texteLiaison = «  »
Case 7
If Langue = 0 Then nbUnites = nbUnites + 10
Case 8
If Langue <> 2 Then texteLiaison = « - »
Case 9
If Langue = 0 Then
nbUnites = nbUnites + 10
texteLiaison = « - »
End If
End Select

NbEnDizaines = tabDizaines(nbDizaines)
If Langue <> 2 And Nombre = 80 Then NbEnDizaines = tabDizaines(nbDizaines) & « s »
If (tabUnites(nbUnites) <> «  ») Then NbEnDizaines = NbEnDizaines & texteLiaison & tabUnites(nbUnites)

End Fun

Bonsoir,

A tester

Option Explicit

Public Function ChLettres(Montant As Double, Optional devise As Byte = 0, Optional Langue As Byte = 0) As String

    Dim partieEntiere As Variant, partieDecimale As Integer
    Dim texteDevise As String, texteCentimes As String, position As Byte

    If (Montant < 0) Then Montant = Abs(Montant)

    partieEntiere = Int(Montant)

    position = InStr(1, Montant, ",")
    If (position < 1) Then position = InStr(1, Montant, ",")

    If (position > 0) Then
        position = position + 1
        If devise = 0 Or devise = 4 Then
            partieDecimale = Left(Mid(Montant, position), 3)
        Else
            partieDecimale = Left(Mid(Montant, position), 2)
        End If
    Else
        partieDecimale = 0
    End If

    If partieDecimale = 0 Then
        If partieEntiere > 999999999999999# Then
            ChLettres = "# TropGrand #"
            Exit Function
        End If
    Else
        If partieEntiere > 9999999999999# Then
            ChLettres = "# TropGrand #"
            Exit Function
        End If
    End If

    Select Case devise
        Case 0
            If partieDecimale > 0 Then texteDevise = " virgule "
        Case 1
            texteDevise = " euro"
            If partieDecimale > 0 Then texteCentimes = " centimes"
        Case 2
            texteDevise = " dollar"
            If partieDecimale > 0 Then texteCentimes = " cents"
        Case 3
            If partieDecimale > 0 Then
                texteDevise = " virgule "
                texteCentimes = " ariary"
            Else
                texteDevise = " ariary"
            End If
        Case 4
            texteDevise = " dinar"
            If partieDecimale = 1 Then texteCentimes = " millime"
            If partieDecimale > 1 Then texteCentimes = " millimes"
    End Select

    If partieEntiere = 0 Then
        texteDevise = "zéro " & texteDevise
    End If

    If devise = 1 Or devise = 2 Or devise = 4 Then
        If partieEntiere > 1 Then texteDevise = texteDevise & "s"
    End If

    ChLettres = NbEnMille(CDbl(partieEntiere), Langue) & texteDevise & " " & NbEnCent(partieDecimale, Langue) & texteCentimes

End Function

Private Function NbEnMille(Nombre As Double, Langue As Byte) As String

    Dim tabBloc As Variant: Dim numBloc As Byte
    Dim nombreBloc As Integer, reste As Double, texteBloc As String
    tabBloc = Array("", " mille", " million", " milliard", " billion")
    numBloc = 0
    If Nombre = 0 Then Exit Function

    Do While Nombre > 0
        reste = Int(Nombre / 1000)
        nombreBloc = Nombre - (reste * 1000)

        If nombreBloc > 0 Then
            If numBloc = 0 And nombreBloc = 80 Then
                texteBloc = "quatre-vingts"
            Else
                texteBloc = NbEnCent(CInt(nombreBloc), Langue)
            End If

            Select Case numBloc
                Case 0
                    ' unités
                Case 1
                    If nombreBloc = 1 Then
                        texteBloc = "mille"
                    Else
                        texteBloc = texteBloc & " mille"
                    End If
                Case Else
                    If nombreBloc = 1 Then
                        texteBloc = "un" & tabBloc(numBloc)
                    Else
                        texteBloc = texteBloc & tabBloc(numBloc) & "s"
                    End If
            End Select

            NbEnMille = texteBloc & " " & NbEnMille
        End If

        Nombre = reste
        numBloc = numBloc + 1
    Loop

    NbEnMille = Application.WorksheetFunction.Trim(UCase(Left(NbEnMille, 1)) & Mid(NbEnMille, 2))

End Function

Private Function NbEnCent(Nombre As Integer, Langue As Byte) As String

    Dim tabUnites As Variant
    Dim NbCent As Byte, reste As Byte, texteReste As String

    tabUnites = Array("", "un", "deux", "trois", "quatre", "cinq", "six", "sept", "huit", "neuf", "dix")

    NbCent = Int(Nombre / 100): reste = Nombre - (NbCent * 100)
    texteReste = NbEnDizaines(reste, Langue)

    Select Case NbCent
        Case 0
            NbEnCent = texteReste
        Case 1
            If reste = 0 Then
                NbEnCent = "cent"
            Else
                NbEnCent = "cent" & " " & texteReste
            End If
        Case Else
            If reste = 0 Then
                NbEnCent = tabUnites(NbCent) & " cents"
            Else
                NbEnCent = tabUnites(NbCent) & " cent " & texteReste
            End If
    End Select

End Function

Private Function NbEnDizaines(Nombre As Byte, Langue As Byte) As String

    Dim tabUnites As Variant, tabDizaines As Variant
    Dim nbUnites As Byte, nbDizaines As Byte
    Dim texteLiaison As String

    tabUnites = Array("", "un", "deux", "trois", "quatre", "cinq", "six", "sept", "huit", "neuf", "dix", _
                      "onze", "douze", "treize", "quatorze", "quinze", "seize", "dix-sept", "dix-huit", "dix-neuf")
    tabDizaines = Array("", "", "vingt", "trente", "quarante", "cinquante", "soixante", "soixante", "quatre-vingt", "quatre-vingt")

    If Langue = 1 Then
        tabDizaines(7) = "septante"
        tabDizaines(9) = "nonante"
    End If

    If Langue = 2 Then tabDizaines(8) = "huitante"

    nbDizaines = Int(Nombre / 10): nbUnites = Nombre - (nbDizaines * 10)
    texteLiaison = "-": If nbUnites = 1 Then texteLiaison = " et "

    Select Case nbDizaines
        Case 0
            texteLiaison = ""
        Case 1
            nbUnites = nbUnites + 10
            texteLiaison = ""
        Case 7
            If Langue = 0 Then nbUnites = nbUnites + 10
        Case 8
            If Langue <> 2 Then texteLiaison = "-"
        Case 9
            If Langue = 0 Then
                nbUnites = nbUnites + 10
                texteLiaison = "-"
            End If
    End Select

    NbEnDizaines = tabDizaines(nbDizaines)
    If (tabUnites(nbUnites) <> "") Then NbEnDizaines = NbEnDizaines & texteLiaison & tabUnites(nbUnites)

End Function

Slts

Bonjour

Ce code fonctionne (la fonction ‹ MontantEnLettres › donne le résultat final):

Function NumToCars(Nombre)

Dim Phrase, Milliers, Millions, Term

strNb = CStr(Nombre)

For C = Len(strNb) To 1 Step -1

    Unite = CInt(Mid(strNb, C, 1))
    Niv = Niv + 1
    
    Select Case Niv
    Case 1
        
        If Unite <> "0" Then
            Phrase = Chif(Unite)
        Else
            Retenue = 1
        End If
        
    Case 2
    
        If Unite <> "0" Then
            
            If Retenue < 1 Then
                Ext = IIf(Phrase = "un" And Unite <> 9, " et ", " ")
                If Unite <> 7 And Unite <> 9 And Unite <> 1 Then
                    Phrase = Chif(Unite & "0") & Ext & Phrase
                Else
                    Phrase = IIf(Unite <> 1, Chif(Unite - 1 & "0") & Ext, "") & Chif(10 + ExUnite)
                End If
            Else
                If Unite <> 7 And Unite <> 9 Then
                    Phrase = Chif(Unite & "0")
                Else
                    Phrase = Chif(Unite - 1 & "0") & " " & Chif(10)
                End If
                Retenue = 0
            End If
            
        Else
        
            Retenue = 1
            
        End If
        
    Case 3
    
        Base = Chif(10 ^ (Niv - 1))
        If Unite <> "0" Then
            Uni = IIf(Unite > 1, Chif(Unite) & " ", "")
            Phrase = Uni & Base & " " & Phrase
        Else
            Retenue = 1
        End If
        
        
    Case 4
    
        F1 = Len(strNb) - 3: F2 = Len(strNb) - 5
        If F2 <= 0 Then F2 = 1
        Milliers = NumToCars(Mid(strNb, F2, F1 - F2 + 1))
        If Not (IsEmpty(Milliers) Or Milliers = "") Then
            Phrase = Trim(IIf(Milliers = "un", "", Milliers) & " mille " & Phrase)
        End If
    
    Case 7
    
        F1 = Len(strNb) - 6: F2 = Len(strNb) - 8
        If F2 <= 0 Then F2 = 1
        Millions = NumToCars(Mid(strNb, F2, F1 - F2 + 1))
        Term = IIf(Millions <> "un", "s", "")
        Phrase = Millions & " million" & Term & " " & Phrase
    
    Case Else
    
    End Select
    
    ExUnite = Unite

Next_c:

Next C


NumToCars = Trim(Phrase)

End Function
Function Chif(N)

Select Case N
Case 1
    Chif = "un"
Case 2
    Chif = "deux"
Case 3
    Chif = "trois"
Case 4
    Chif = "quatre"
Case 5
    Chif = "cinq"
Case 6
    Chif = "six"
Case 7
    Chif = "sept"
Case 8
    Chif = "huit"
Case 9
    Chif = "neuf"
Case 10
    Chif = "dix"
Case 11
    Chif = "onze"
Case 12
    Chif = "douze"
Case 13
    Chif = "treize"
Case 14
    Chif = "quatorze"
Case 15
    Chif = "quinze"
Case 16
    Chif = "seize"
Case 17
    Chif = "dix-sept"
Case 18
    Chif = "dix-huit"
Case 19
    Chif = "dix-neuf"

    
Case 20
    Chif = "vingt"
Case 30
    Chif = "trente"
Case 40
    Chif = "quarante"
Case 50
    Chif = "cinquante"
Case 60
    Chif = "soixante"
Case 80
    Chif = "quatre-vingt"
Case 100
    Chif = "cent"
Case 1000
    Chif = "mille"
Case 1000000
    Chif = "million"
Case Else
End Select

End Function

Function MontantEnLettres(Montant As Double)

Dim Mt As String

Mt = Trim(CStr(Montant))
If Mt Like "-*" Then
    Negatif = "moins "
    Mt = Mid(Mt, 2)
Else
    Negatif = ""
End If

MEL = Split(Mt, ",")
partieEnt = NumToCars(MEL(0))
If partieEnt = "" Then partieEnt = "zéro"
If Not (partieEnt = "zéro" Or partieEnt = "un") Then plEuro = "s"
If partieEnt Like "*vingt" Or partieEnt Like "*cent" Then plEnt = "s"

If UBound(MEL, 1) > 0 Then
    If Len(MEL(1)) = 1 Then MEL(1) = MEL(1) & "0"
    partieDec = NumToCars(MEL(1))
    If Not (partieDec = "zéro" Or partieDec = "un") Then plCent = "s"
    If partieDec Like "*vingt" Or partieDec Like "*cent" Then plDec = "s"
End If
MontantEnLettres = Negatif & partieEnt & plEnt & " euro" & plEuro & IIf(partieDec <> "", " et " & partieDec & plDec & " cent" & plCent, "")

End Function

2 « J'aime »

bonjour.
peu être que cette page peu t’aider

https://perso.unamur.be/~jmlamber/chlettres.html

1 « J'aime »

Merci beaucoup. Cette page m’a aidé beaucoup mais le créateur a proteger le code donc je ne trouve pas la dedans mais je veux ajouter quelque unités monétaire dans ce code

bonjour.

le code de la macro

macro -2.pdf (296,8 Ko)