XL 2013 Convertir chiffres en lettres en anglais avec 3 nombre après virgule

[Galaxy_2019]

Bonjour le Forum,

Vue que je suis nul en VBA, je me suis coincé et j'ai pas trouvé une solution adéquate sur le Net.

Mon besoin c'est de trouvé un code VBA qui convertir les chiffres en lettres en anglais avec 3 chiffres après la virgule et selon le devise aux choix.

J'ai trouvé un fichier (en pièce jointe) qui convertir les chiffres en lettres en français mais j'ai pas pu l'adapté.

Merci infiniment

Dans l'attente de votre réponses.

Cordialement

 

[cp4]

Bonjour,

les trois chiffres sont exprimés en "Fils"(Dinar Kuwaiti)
12,365 ------>Twelve Dinars and Three hundred and sixty five Fils

Cordialement

@Galaxy_2019 : J'ai pu te trouver le code ci-joint mais en Français et pour des dinars Tunisiens.
Je te laisse remplacé les chiffres en anglais et millimes pas Fils. J'espère que ça répond bien à tes attentes. Il faut mettre les mains dans le cambouis.
Bon courage

 

[cp4]

Bonjour,
Apparemment, tu n'aimes pas te salir les mains. Mais là, il n'est pas question de se salir.
Il fallait juste faire un effort de compréhension du code.
ci-joint code modifié pour Dinar Kowetien (voir Tunisien comme précisé par PatrickToulon, en modifiant Fils par Millime).

Option Explicit

Function SpellDinarKuwaiti(ByVal MyNumber)
   Dim Dinars, Fils, Temp, DecimalPlace, Count
   ReDim Place(9) As String
   Place(2) = " Thousand "
   Place(3) = " Million "
   Place(4) = " Billion "
   Place(5) = " Trillion "

   ' String representation of amount.
   MyNumber = Trim(Str(MyNumber))

   ' Position of decimal place 0 if none.
   DecimalPlace = InStr(MyNumber, ".")
   ' Convert Fils and set MyNumber to dollar amount.
   If DecimalPlace > 0 Then
      Fils = GetHundreds(Left(Mid(MyNumber, DecimalPlace + 1) & "000", 3))
      MyNumber = Trim(Left(MyNumber, DecimalPlace - 1))
   End If

   Count = 1
   Do While MyNumber <> ""
      Temp = GetHundreds(Right(MyNumber, 3))
      If Temp <> "" Then Dinars = Temp & Place(Count) & Dinars
      If Len(MyNumber) > 3 Then
MyNumber = Left(MyNumber, Len(MyNumber) - 4)
      Else
         MyNumber = ""
      End If
      Count = Count + 1
   Loop

   Select Case Dinars
   Case ""
      Dinars = "No Dinars"
   Case "One"
      Dinars = "One Dollar"
   Case Else
      Dinars = Dinars & " Dinars"
   End Select

   Select Case Fils
   Case ""
      Fils = " and No Fils"
   Case "One"
      Fils = " and One Cent"
   Case Else
      Fils = " and " & Fils & " Fils"
   End Select

   SpellDinarKuwaiti = Dinars & Fils
Debug.Print "SpellDinarKuwaiti =" & SpellDinarKuwaiti
End Function

'*******************************************
' Converts a number from 100-999 into text *
'*******************************************

Function GetHundreds(ByVal MyNumber)
   Dim Result As String

   If Val(MyNumber) = 0 Then Exit Function
   MyNumber = Right("000" & MyNumber, 3)
Debug.Print MyNumber
   ' Convert the hundreds place.
   If Mid(MyNumber, 1, 1) <> "0" Then
      Result = GetDigit(Mid(MyNumber, 1, 1)) & " Hundred "
   End If

   ' Convert the tens and ones place.
   If Mid(MyNumber, 2, 1) <> "0" Then
      Result = Result & GetTens(Mid(MyNumber, 2))
   Else
      Result = Result & GetDigit(Mid(MyNumber, 3))
   End If

   GetHundreds = Result

End Function

'*********************************************
' Converts a number from 10 to 99 into text. *
'*********************************************
Function GetTens(TensText)
   Dim Result As String
Debug.Print "Left(TensText, 1):" & Left(TensText, 1)
   Result = ""           ' Null out the temporary function value.
   If Val(Left(TensText, 1)) = 1 Then   ' If value between 10-19...
      Select Case Val(TensText)
      Case 10: Result = "Ten"
      Case 11: Result = "Eleven"
      Case 12: Result = "Twelve"
      Case 13: Result = "Thirteen"
      Case 14: Result = "Fourteen"
      Case 15: Result = "Fifteen"
      Case 16: Result = "Sixteen"
      Case 17: Result = "Seventeen"
      Case 18: Result = "Eighteen"
      Case 19: Result = "Nineteen"
      Case Else
      End Select

   Else                                 ' If value between 20-99...

      Select Case Val(Left(TensText, 1))
      Case 2: Result = "Twenty "
      Case 3: Result = "Thirty "
      Case 4: Result = "Forty "
      Case 5: Result = "Fifty "
      Case 6: Result = "Sixty "
      Case 7: Result = "Seventy "
      Case 8: Result = "Eighty "
      Case 9: Result = "Ninety "
      Case Else
      End Select

      Result = Result & GetDigit(Right(TensText, 1))  ' Retrieve ones place.

   End If

   GetTens = Result
End Function

'*******************************************
' Converts a number from 1 to 9 into text. *
'*******************************************
Function GetDigit(Digit)
   Select Case Val(Digit)
   Case 1: GetDigit = "One"
   Case 2: GetDigit = "Two"
   Case 3: GetDigit = "Three"
   Case 4: GetDigit = "Four"
   Case 5: GetDigit = "Five"
   Case 6: GetDigit = "Six"
   Case 7: GetDigit = "Seven"
   Case 8: GetDigit = "Eight"
   Case 9: GetDigit = "Nine"
   Case Else: GetDigit = ""
   End Select
End Function

Bonne journée.

 

[patricktoulon]

re
@cp4
pas de bras pas de chocolat

 

[Galaxy_2019]

@Galaxy_2019 : J'ai pu te trouver le code ci-joint mais en Français et pour des dinars Tunisiens.
Je te laisse remplacé les chiffres en anglais et millimes pas Fils. J'espère que ça répond bien à tes attentes. Il faut mettre les mains dans le cambouis.
Bon courage

Bonjour cp4, patricktoulon, et le Forum,

Désolé pour le retard

@cp4: j'ai déjà essayé de modifier le code selon la monnaies, mais je me suis coincé quant à les 3 chiffres après la virgule.

Merci pour votre code en poste #17, je vais le testé, et te reviendra, merci beaucoup cp4

Merci à vous

 

[patricktoulon]

re
@cp4 si tu va bien chercher c'est beaucoup plus simple que ça
en fait tu a un nombre décimal ou pas
comment disséquer les tranches
ben par exemple

Sub test()
    nbletterUS 13521.57
End Sub

Function nbletterUS(nombre As String)    '!!!!as string!!!!!!'3 ficche apres la virgule meme si il n'y sont pas dans le nombre
    ul = Array("", "One", "Two", "Three", "Four", "Five", "Six", "Seven", "Eight", "Nine", "Ten", "Eleven", "Twelve", "Thirteen", "Fourteen", "Fifteen", "Sixteen", "Seventeen", "Eighteen", "Nineteen")
    diz = Array("", "", "Twenty ", "Thirty ", "Forty ", "Fifty ", "Sixty ", "Seventy ", "Eighty ", "Ninety ")

    t = Split(nombre, ",")
    For i = 0 To UBound(t)
        If i = 0 Then
            Z = Split(Trim(Format(t(0), Application.Rept(" @@@", Len(t(0) / 3) + 1))), " ")
        Else
            Z = Array(Left(t(1) & "00", 3))
        End If
        For p = 0 To UBound(Z)
            c = "": d = "": u = ""

            If Z(p) > 99 Then c = IIf(Left(Z(p), 1) > 1, ul(Left(Z(p), 1)) & " hundred", " hundred") Else c = ""
            dx = Val(Right(Z(p), 2))
            If dx < 20 Then d = "": u = ul(Right(dx, 2))
            If dx > 20 Then d = diz(Left(dx, 1)): u = ul(Right(dx, 1))

            Debug.Print Z(p) & ": " & c & " " & d & u
        Next
Debug.Print "--------------"
    Next
End Function

en US c'est hyper simple en fait

 

[cp4]

re
@cp4 si tu va bien chercher c'est beaucoup plus simple que ça
en fait tu a un nombre décimal ou pas
comment disséquer les tranches
ben par exemple

Sub test()
    nbletterUS 13521.57
End Sub

Function nbletterUS(nombre As String)    '!!!!as string!!!!!!'3 ficche apres la virgule meme si il n'y sont pas dans le nombre
    ul = Array("", "One", "Two", "Three", "Four", "Five", "Six", "Seven", "Eight", "Nine", "Ten", "Eleven", "Twelve", "Thirteen", "Fourteen", "Fifteen", "Sixteen", "Seventeen", "Eighteen", "Nineteen")
    diz = Array("", "", "Twenty ", "Thirty ", "Forty ", "Fifty ", "Sixty ", "Seventy ", "Eighty ", "Ninety ")

    t = Split(nombre, ",")
    For i = 0 To UBound(t)
        If i = 0 Then
            Z = Split(Trim(Format(t(0), Application.Rept(" @@@", Len(t(0) / 3) + 1))), " ")
        Else
            Z = Array(Left(t(1) & "00", 3))
        End If
        For p = 0 To UBound(Z)
            c = "": d = "": u = ""

            If Z(p) > 99 Then c = IIf(Left(Z(p), 1) > 1, ul(Left(Z(p), 1)) & " hundred", " hundred") Else c = ""
            dx = Val(Right(Z(p), 2))
            If dx < 20 Then d = "": u = ul(Right(dx, 2))
            If dx > 20 Then d = diz(Left(dx, 1)): u = ul(Right(dx, 1))

            Debug.Print Z(p) & ": " & c & " " & d & u
        Next
Debug.Print "--------------"
    Next
End Function

en US c'est hyper simple en fait

@patricktoulon : Merci beaucoup, J'essaie d'apprendre et me perfectionner.
J'ai donc essayé de comprendre le code mis en ligne pas kiki29.
Si J'ai réussi à l'adapter pour qu'il prenne en charge les millimes. J'avoue ne pas avoir tout compris.
En effet, dans code initial (en dollar) par exemple la ligne ci-dessous:

Cents = GetTens(Left(Mid(MyNumber, DecimalPlace + 1) & "00", 2))
'pourquoi la concatenation avec "00"' car la ligne ci-dessous renvoie la même 
'chaine (les 2 chiffres après la virgule)
Cents = GetTens(Left(Mid(MyNumber, DecimalPlace + 1) , 2))

Je vais prendre le temps d'étudier ton code.
Merci bonne soirée.

 

[patricktoulon]

re
bonjour pour le coup j'ai revu ma fonction nblettreFR
j'ai entièrement reconstruit le moteur différemment
et j'ai intégré
le sans monnaie (3 chiffres après la virgule)
avec monnaie euro,dollar (2 chiffres après la virgule)
avec monnaie dinar,dinar k,(3 chiffres après la virgule centimes fil/millime)
on pourra ajouter une monnaie dans le select case fric avec ses paramètres

bientôt dispo dans la ressource (je met ça au propre)
je ferais la version anglais avec un moteur similaire

 

[cp4]

re
bonjour pour le coup j'ai revu ma fonction nblettreFR
j'ai entièrement reconstruit le moteur différemment
et j'ai intégré
le sans monnaie (3 chiffres après la virgule)
avec monnaie euro,dollar (2 chiffres après la virgule)
avec monnaie dinar,dinar k,(3 chiffres après la virgule centimes fil/millime)
on pourra ajouter une monnaie dans le select case fric avec ses paramètres

bientôt dispo dans la ressource (je met ça au propre)
je ferais la version anglais avec un moteur similaire

Bonjour PatrickToulon "le vaillant" ,
Merci pour ta disponibilité et ton dévouement pour cette communauté.
Merci de m'envoyer un petit message lorsque ça sera au point.

Bonne journée.

 

[patricktoulon]

re
la voici des que ce sera dispo

https://www.excel-downloads.com/res...s-et-autres.1134/updates#resource-update-1531