XL 2019 Convertir des chiffres en lettres

Staple1600

XLDnaute Barbatruc
Re

•>patricktoulon
Voila un tit exemple de synergie/émulation comme jadis ;)
Merci d'avoir fait la poussière dans mon code de 2012 ;)
(8 ans quand même)
 

Staple1600

XLDnaute Barbatruc
Re

Moi, je préfère les majuscules ;)
VB:
Function oW_CHIFFRELETTRE(num$)
' Dans VBE, Menu: Outils/Références:cochez: Microsoft Word XX.0 Object Library )
'crédits: Staple pour l'idée de départ | patricktoulon pour l'upgrade et "épurage" ;-)
Dim oWS As Worksheet, oOLEWd As OLEObject, oWD As Document, Cts$
Cts = Split(num, ",")(1)
Application.ScreenUpdating = False
Set oWS = ActiveSheet
Set oOLEWd = oWS.OLEObjects.Add(ClassType:="Word.Document.8", Link:=False, DisplayAsIcon:=True)
Set oWD = oOLEWd.Object
oWD.Fields.Add Range:=oWD.Range, Type:=wdFieldQuote, Text:="=" & Split(num, ",")(0) & "\*CARDTEXT \*Upper"
oWD.Range.Characters(Len(oWD.Range.Text)).InsertAfter " EUROS ET " 'Eureka !
oWD.Fields.Add Range:=oWD.Range.Characters(Len(oWD.Range.Text)), Type:=wdFieldQuote, Text:="=" & Cts & "\*CARDTEXT \*Upper"
oWD.Range.Characters(Len(oWD.Range.Text)).InsertAfter " CENTIMES." 'Alleluia !!!
oWD.Fields.Update
oW_CHIFFRELETTRE = oWD.Range.Text
'On Error Resume Next
If Not oOLEWd Is Nothing Then oOLEWd.Delete
End Function

Sub test_B()
Dim NomBre As String
NomBre = InputBox("Saisir un montant:" & Chr(13) & "Ex: 1600,12", "Saisie", "1600,12")
MsgBox oW_CHIFFRELETTRE(NomBre), vbInformation, "Conversion Chiffre en Lettre"
End Sub
 

patricktoulon

XLDnaute Barbatruc
re
c'est pas trop ca qui me préoccupe c'est le mode latebinding que je n'arrive pas a trouver

je souhaiterais (pas cocher de reference )
et dimer
oOLEWd en object
oWD en object

pour oOLEWd ca va pas de soucis
mais pour oWD ca plante un msgbox " limite atteint "

oWD c'est quoi ?le document de oOLEWd ? ou simplement le .object de oOLEWd

VB:
'******************************************************************************************
'basé sur l'exemple de Staple1600 (Exceldownload) version date 19/05/2012
'https://www.excel-downloads.com/threads/xl-oleobject-word-par-vba-piloter-champs.184716/
'patricktoulon upgrade et "épurage";transformation en fonction  version date 23/03/2020
'******************************************************************************************
Function CHIFFRES_LETTRES(num$)
Dim oWS As Worksheet, oOLEWd As OLEObject
'Dim Cts ,oWD As Document!!!!!!?????????
Dim Cts, oWD As Object   '!!!!!! ne fonctionne pas en latebinding (sans référence activé)
' Dans VBE, Menu: Outils/Références:cochez: Microsoft Word XX.0 Object Library )!!!!!!!!!!!!!!!
Cts = Split(Replace(num, ".", ","), ",")
Application.ScreenUpdating = False
Set oWS = ActiveSheet
With oWS.OLEObjects.Add(ClassType:="Word.Document.8", Link:=False, DisplayAsIcon:=False)
.Object.Fields.Add Range:=.Object.Range, Type:=wdFieldQuote, Text:="=" & Cts(0) & "\*CARDTEXT"
.Object.Range.Characters(Len(.Object.Range.Text)).InsertAfter " EUROS ET " 'Eureka !
.Object.Fields.Add Range:=.Object.Range.Characters(Len(.Object.Range.Text)), Type:=wdFieldQuote, Text:="=" & Cts(1) & "\*CARDTEXT"
.Object.Range.Characters(Len(.Object.Range.Text)).InsertAfter " CENTIMES." 'Alleluia !!!
.Object.Fields.Update
CHIFFRES_LETTRES = .Object.Range.Text
If Not .Object.Parent Is Nothing Then .Delete 'supression de l'oleobject word
End With
End Function

Sub test()
num$ = InputBox("Saisir un montant:" & Chr(13) & "Ex: 123,89", "Saisie", "123,89")
MsgBox CHIFFRES_LETTRES(num)
End Sub
comment se passer de la référence pour le ".object" ???????????????
 
Dernière édition:

Staple1600

XLDnaute Barbatruc
Re

Suffit d'ajouter la référence par VBA
(Il doit y avoir des exemples ici ou là)
Pour ce qui me concerne, en 2012 c'était juste un petit exercice pour ma curiosité personnelle.
(Pas pour un usage in "real life" d'autant plus que CARDTEXT ne fonctionne que jusqu'à 999 999,00)
Et n'oublions pas les Macistes, pour lesquels le code ne fonctionnera pas ;)

PS: C'est pas Staple1660 mais Staple1600 ;)
 

patricktoulon

XLDnaute Barbatruc
re
oui j'ai vu la limite de 999 999 c'est vraiment dommage

j'y ai pensé a l'ajouter dynamiquement mais bon j'aurais préféré trouver le clisd
j'ai ajouté le decimal ou pas et le "s" a euro selon la valeur(je sais que ça ça fait debat)
VB:
'******************************************************************************************
'basé sur l'exemple de Staple1600 (Exceldownload) version date 19/05/2012
'https://www.excel-downloads.com/threads/xl-oleobject-word-par-vba-piloter-champs.184716/
'patricktoulon upgrade et "épurage";transformation en fonction  version date 23/03/2020
' Dans VBE, Menu: Outils/Références:cochez: Microsoft Word XX.0 Object Library )!!!!!!!!!!!!!!!
'******************************************************************************************
Function CHIFFRES_LETTRES(num$)
    Dim oWS As Worksheet, oOLEWd As OLEObject, et$, euro$
    'Dim Cts ,oWD As Document!!!!!!?????????
    Dim Cts, oWD As Object   '!!!!!! ne fonctionne pas en latebinding (sans référence activé)
      Cts = Split(Replace(num, ".", ","), ",")
    euro = "EURO"
    If Val(Cts(0)) > 999999 And Val(Cts(0)) Mod 10 = 0 Then euro = "d'" & euro 'inutile on y arrive pas avec cet object
    If Val(Cts(0)) > 1 Then euro = euro & "s"
    If UBound(Cts) = 1 Then et = " et " Else et = ""
    Application.ScreenUpdating = False
    Set oWS = ActiveSheet
    With oWS.OLEObjects.Add(ClassType:="Word.Document.8", Link:=False, DisplayAsIcon:=False)
        .Object.Fields.Add Range:=.Object.Range, Type:=wdFieldQuote, Text:="=" & Cts(0) & "\*CARDTEXT"
        .Object.Range.Characters(Len(.Object.Range.Text)).InsertAfter " " & euro & et  'Eureka !
        If UBound(Cts) = 1 Then 'si decimales
            .Object.Fields.Add Range:=.Object.Range.Characters(Len(.Object.Range.Text)), Type:=wdFieldQuote, Text:="=" & Cts(1) & "\*CARDTEXT"
            .Object.Range.Characters(Len(.Object.Range.Text)).InsertAfter " CENTIMES."    'Alleluia !!!
        End If
        .Object.Fields.Update
        CHIFFRES_LETTRES = UCase(.Object.Range.Text)
        If Not .Object.Parent Is Nothing Then .Delete    'supression de l'oleobject word
    End With
End Function

Sub test()
    num$ = InputBox("Saisir un montant:" & Chr(13) & "Ex: 123,89", "Saisie", "999999.45")
    MsgBox CHIFFRES_LETTRES(num)
End Sub
 
Dernière édition:

Staple1600

XLDnaute Barbatruc
Re

Tu veux parler du GUID de la référence pour Word?
"{00020905-0000-0000-C000-000000000046}", "Word"

PS: Sinon, c'est toujours Staple1600, pas 1660 !
 

Staple1600

XLDnaute Barbatruc
Re

Je n'ai fais que tester l'ajout de la référence Word par code VBA.
C'est ce test qui OK sur mon Excel 2013.
 

King Luymas

XLDnaute Nouveau
bonjour
colle ca dans un module
VB:
Option Explicit
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", ""): If UBound(Part) > 0 Then If Part(1) = 0 Then Part = Array(Part(0)): centime = "": euro = Replace(euro, "et", "")
    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
et dans une cellule
exemple

=si(A1>0;NblettreFR(A1);"")
terminé ;)
Voir la pièce jointe 1059344
Bonsoir, et merci pour le code, mais je voudrais savoir comment faire dans ce code afin que le montant s’arrête à deux décimales?
car j'ai copie ce code et voila les résultats que cela donne:
 

Fichiers joints

Jouxte

XLDnaute Occasionnel
Bonjour à toutes et tous,

Merci pour ce très beau travail qui respecte les règles grammaticales pour le tiret.
J'ai trois petites remarques :
=>100 s'accorde s'il est multiplié et lorsqu'il n'y a pas de chiffre après. Dans le cas contraire, il est invariable. Par exemple : deux cents euros et deux cent un euros
200deux cent euros
201deux cent un euros
=> Il y a un petit bug sur les milliers

1276,036un mille deux cent soixante-seize euros et trente-six Centimes

=> si le résultat d'un calcul amène à plusieurs chiffres après la virgule et que les premiers sont des zéros, la macro ne les considère pas.

126,0036cent vingt-six euros et trente-six Centimes

J'ai vu la macro sans les devises, mais elle ne respecte pas la règle du tiret. mais je n'ai peut-être pas trouvé la dernière version.
Merci encore.
Bonne soirée.
 

patricktoulon

XLDnaute Barbatruc
bonsoir jouxte
c'est voulu
en monnaie pas plus de 2 chiffre après la virgule
1 euro =100 centimes après 99 on revient a zero et augmente de 1 l'entier, il ne peut donc pas y avoir 3 caractères numériques après la virgule

quand tu lis les étiquettes de prix dans les magasin tu lis 126,36€ et non 126,036€

:rolleyes:
 

patricktoulon

XLDnaute Barbatruc
si tu veux la version qui te donne l'arrondi de 036 c'est ma méthode globale qu'il te faut
126.036 donnera
Capture.JPG

la formule
=SI(A6=0;" ";nBlettre_methode_globale((A6);"euro";1))

en vba
Sub testx()
MsgBox nBlettre_methode_globale(126.036, "euro", True)
End Sub

la fonction
VB:
Option Explicit
 
Function nBlettre_methode_globale(nombres As String, Optional ByVal sstr As String = "virgule", Optional ByVal finance As Boolean = False)
    Dim en_dec(2), unit1, unit10, ms, cms As Long, decs As Long, ex As Long, ddd As String, centi As String, e As Long, i As Long, a As Long, dix As Long
    Dim nombre As String, u As String, c As String, ct As String, et As String, ss As String, neg As Boolean
    unit1 = Array("", " Un", " Deux", " Trois", " Quatre", " Cinq", " Six", " Sept", " Huit", " Neuf", " Dix", " Onze", " Douze", " treize", " Quatorze", " Quinze", " Seize", " Dix-Sept", " Dix-Huit", " Dix-Neuf", " cent", " zéro")
    unit10 = Array("", " dix", " vingt", " trente", " quarante", " cinquante", " soixante", " soixante-dix", " quatre-vingt", " quatre-vingt-dix", " cent")
    ms = Array("", " sextillion", " Quintillion", " Quatrillion", " Trillion", " Billiard", " Billion", " milliard", " million", " mille", ""): cms = UBound(ms)
 
    If Left(nombres, 1) = "-" Then nombres = Mid(nombres, 2, Len(nombres)): neg = True
    decs = 0: nombres = Replace(nombres, ".", ","): en_dec(0) = Split(nombres, ",")(0): If InStr(nombres, ",") > 0 Then en_dec(1) = Split(nombres, ",")(1): decs = 1    'on separe le decimal de l'entier
    If Len(en_dec(0)) Mod 3 <> 0 Then en_dec(0) = Application.Rept("0", 3 - Len(en_dec(0)) Mod 3) & en_dec(0)    'on formate l'entier a 3 chiffre par tranche
    If decs = 1 Then en_dec(1) = Right("00" & Round(Val("0." & en_dec(1)), 2) * 100, 3)  ' NOUVELLE METHODE POUR ADAPTER LE DECIMAL on formate a 3 chiffres
    ex = cms - (Len(en_dec(0)) / 3) + 1    ' index de point de depart des expressions dans l'array ms
    ddd = IIf(Val(en_dec(0)) > 999000 And Val(Right(en_dec(0), 6)) = 0, IIf("aAeEiIoOuUyY" Like "*" & Left(sstr, 1) & "*", " d' ", " de"), " ")
    centi = IIf(sstr <> "dollar", " centime", " cent")
    If sstr = "virgule" Then centi = ""
    sstr = IIf(Val(en_dec(0)) > 1, sstr & "s", sstr)
    If decs = 1 Then centi = IIf(Val(en_dec(1)) > 1, centi & "s", centi)
    For e = 0 To decs
        For i = 1 To Len(en_dec(e)) Step 3
            a = ex + Round(i / 3)    'position actuelle de ms
            nombre = Mid(en_dec(e), i, 3)    ' la tranche
            dix = Mid(nombre, 2, 1): u = Right(nombre, 1): c = Left(nombre, 1): If c > 1 Then c = c: ct = unit1(20) & IIf(Val(dix & u) > 0, "", "s") Else: ct = "": If c = 1 Then c = 20
            If dix = 1 Or dix = 7 Or dix = 9 And Right(u, 1) > 0 Then dix = dix - 1: u = u + 10   'on corrige le 1,7,9
            If dix > 1 And dix <> 8 And Right(u, 1) = 1 Then et = " et" Else: If dix = 0 Or u = 0 Then et = "" Else et = "-"  ' on accorde de 1 a 99
 
            If u = 0 Then If dix = 8 Then If ms(a) = " mille" Then et = "" Else et = "s"     'le s a quatre-vingt tout seul
 
            If nombre = 0 And Len(en_dec(0)) = 3 Then u = 21: dix = 0    ' le zéro si l'entier vaut 0 tout simplement
            If nombre = 0 And i <> 1 Then a = 0
            If nombre = 1 And i = 1 And a = cms - 1 Then u = 0
            If e = 0 And nombre > 1 And a < cms - 1 Then ss = "s" Else ss = ""
            nBlettre_methode_globale = nBlettre_methode_globale & Replace(unit1(c) & ct & unit10(dix) & et & unit1(u), "- ", "-") & IIf(e = 0, ms(a), "") & ss
        Next i
        If finance = False Then
            nBlettre_methode_globale = nBlettre_methode_globale & IIf(e = 0 And decs = 1, " virgule ", "")
        Else
            nBlettre_methode_globale = nBlettre_methode_globale & IIf(e = 0 And decs = 1, ddd & " " & sstr & " et ", IIf(decs = 0, " " & sstr, "")) & IIf(e = 1, centi, "")
        End If
    Next e
    If neg = True Then nBlettre_methode_globale = "moins " & nBlettre_methode_globale
End Function

Sub testx()
MsgBox nBlettre_methode_globale(126.036, "euro", True)
End Sub
a+ ;)
 

Créez un compte ou connectez vous pour répondre

Vous devez être membre afin de pouvoir répondre ici

Créer un compte

Créez un compte Excel Downloads. C'est simple!

Connexion

Vous avez déjà un compte? Connectez vous ici.

Haut Bas