cette fonction converti n'importe quel nombres en toutes lettres avec la monnaie "Euro" en francais

voir la discussion et surtout les mises a jour ICI

VB:
Function NblettreFR(chain As String) As String
    Dim t, dixx&, dix&, cxx&, u&, Part, ms, m, Ul, Diz, n&, I&, seg$, cc$, et$, Ss$, R$, md$, euro$, centime
    Ul = Array("", "un", "deux", "trois", "quatre", "cinq", "six", "sept", "huit", "neuf", "dix", "onze", "douze", "treize", "quatorze", "quinze", "seize", "dix-sept", "dix-huit", "dix-neuf", "cent ")
    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", "")
    If LCase(chain) Like "*[a-z|:|;|/|\]*" Then NblettreFR = "Invalid Chaine!!": Exit Function
    Part = Split(chain, ","): If Len(Part(0)) > 66 Then NblettreFR = "OutOFF(CAR*66)!!": Exit Function
    euro = IIf(Val(Part(0)) > 999000 And Val(Right(Part(0), 6)) = 0, "d'euro", "euro") & IIf(Part(0) > 1, "s ", " ") & IIf(UBound(Part) > 0, "et ", "")
    centime = IIf(UBound(Part) > 0, "Centime", "")
    For n = LBound(Part) To UBound(Part)
         t = Split(Trim(Format(String((300 - Len(Part(n))) Mod 3, "0") & Part(n), WorksheetFunction.Rept(" @@@", Len(String((300 - Len(Part(n))) Mod 3, "0") & Part(n)) / 3))))
        If n = 1 Then If Len(Part(1)) = 1 Then t = Array("0" & Part(1) & "0")    'ajustement centime(0.5 = 0.50)
        m = UBound(ms) - UBound(t)
        For I = LBound(t) To UBound(t)
             cxx = Left(t(I), 1): dixx = Right(t(I), 2): dix = Mid(t(I), 2, 1): u = Right(t(I), 1)
            If cxx = 1 Then cxx = 20: cc = "" Else cc = IIf(cxx > 0, " cent ", "")
            If dix = 9 Or dix = 7 Then dix = dix - 1: u = Val(u) + 10
            If dixx > 9 And dixx < 20 Then dix = 0: u = u + 10
            If dix >= 2 And dix <= 7 And (u = 1 Or u = 11) Then et = " et " Else et = IIf(dix <> 0 And u <> 0, "-", " ")
            If dixx = 80 Then Ss = "s" Else Ss = ""
            If I = UBound(t) - 1 And Part(0) = 1000 Then u = 0
            md = ms(m): If Val(t(I)) > 1 And I < UBound(t) - 1 Then md = md & "s"
            R = R & Application.Trim(Ul(cxx) & cc & Diz(dix) & et & Ul(u)) & Ss & IIf(Val(t(I)) > 0, md, "") & " "
              m = m + 1
        Next
        If Val(Part(0)) = 0 Then euro = ""
          R = R & IIf(n = 0, euro, centime): If n = 1 Then If Part(1) > 1 Then R = R & "s" & IIf(Part(0) = 0, " d'euro", "")
        If Trim(R) = "" Then R = ""
    Next n
    NblettreFR = Trim(R)
End Function

exemple
VB:
Sub test()
    Debug.Print NblettreFR("191471851,56")'en string'
    Debug.Print NblettreFR(191471851.56)'en numerique'
End Sub
Auteur
patricktoulon
Version
2.0
  • J'aime
Réactions: TheProdigy et HUGOVIC

Dernières mises à jour

  1. correction orthographique

    bonjour suite a une remarque de de @Ravenheld je corrige l'accords a"cent" dans la tranche de mille
  2. Refonte totale de la fonction et organisation du code pour d’éventuels ajout d'options

    bonjour ce fut long et laborieux et des versions il y en eu ;) chaque ajout d'option mettant...
  3. refonte de la fonction

    Bonjour a tous après plusieurs bizarreries rapportées pas les utilisateurs ( que je n'ai pas...

Derniers avis

Excellent fichier Merci