Converture chiffre en lettre
Fermé
fsoumia
-
16 juil. 2008 à 11:26
Polux31 Messages postés 6917 Date d'inscription mardi 25 septembre 2007 Statut Membre Dernière intervention 1 novembre 2016 - 16 juil. 2008 à 12:36
Polux31 Messages postés 6917 Date d'inscription mardi 25 septembre 2007 Statut Membre Dernière intervention 1 novembre 2016 - 16 juil. 2008 à 12:36
A voir également:
- Converture chiffre en lettre
- Application pour écrire les chiffre en lettre - Télécharger - Outils professionnels
- Telecharger macro convertir chiffre en lettre excel - Télécharger - Tableur
- Excel trier par ordre croissant chiffre - Guide
- Excel supprimer lettre garder chiffre ✓ - Forum Excel
- Ajouter lettre devant chiffre excel ✓ - Forum Excel
1 réponse
Polux31
Messages postés
6917
Date d'inscription
mardi 25 septembre 2007
Statut
Membre
Dernière intervention
1 novembre 2016
1 204
16 juil. 2008 à 12:36
16 juil. 2008 à 12:36
bonjour,
Voilà un code trouvé sur le site de vbFrance
;o)--
«Ce que l'on conçoit bien s'énonce clairement, Et les mots pour le dire arrivent aisément.»
Nicolas Boileau
Voilà un code trouvé sur le site de vbFrance
'Convertion des chiffres en lettres avec choix de devise. 'Montant pôuvant aller jusqu' à 999 999 999.99 'Posibilité de l' incorporrer dans une Feuille Excel. '------------------------------------------------------------------------------------------ 'Auteur : CHAIBAT 'V1.0 'Retouché LE : 22/08/2006 '------------------------------------------------------------------------------------------- '///////////////////////////////////////////////////////////////////////////////////////////////////// Function CONVERTION(pMontant As String, _ pUPE As String, _ pUPD As String, _ SI_0_Zero As Boolean) As String '//paramètres de la fonction '//pMontant = Montant à convertir '//pUPE => Devise pour les unités (chaine vide si pas) '//pUPD => Devise pour les centièmes (chaine vide si pas) '//SI_0_Zero => si vrai: affiche "Zéro pUPD" si faux "" Dim cMontant As Variant 'chaine à traiter à l' intérieure 'de la fonction CONVERTION = "" 'initialisation '//J' ai choisi de traiter le format monétaire 'de la chaine entrée pour que la fonction soit indépendante 'du control que l' utilisateur pourrait faire ou ne pas faire On Error GoTo ERR_CURR cMontant = CCur(pMontant) 'provoque l' erreur si pas monétaire 'code inutil ; erreur interceptée avant ! 'If cMontant > 999999999.99 Then 'erreur liée au système 'dépassement de la capacité de la variable ' MsgBox "Montant impossible à traité..." ' Exit Function 'End If 'si vous ne désirez pas traiter le zéro désactiver cette ligne 'If cMontant = 0 Then Exit Function '****DEBUT DU TRAITEMENT****************************************** cMontant = Format(cMontant, "0.00") 'format monétaire '//variables servant pour la décomposition du montant Dim xDH As Variant 'partie entière Dim xCT As Variant 'partie décimale xDH = Left$(cMontant, Len(cMontant) - 3) xCT = Right$(cMontant, 2) Dim xPart1 As String Dim xPart2 As String Dim xPart3 As String Dim xPart4 As String xPart1 = "" xPart2 = "" xPart3 = "" xPart4 = "" Dim xMt1 As Integer 'Millions Dim xMt2 As Integer 'Milliers Dim xMt3 As Integer 'Centaines Dim xMt4 As Integer 'Centièmes xMt1 = xDH \ 1000000 xMt2 = (xDH Mod 1000000) \ 1000 xMt3 = xDH Mod 1000 xMt4 = xCT '**** 'commence le traitement de chaque partie 'en appelant la fonction CONVERTIR If xMt1 > 0 Then xPart1 = CONVERTIR(xMt1, " Million") If xMt1 > 1 Then xPart1 = xPart1 + "s" End If End If If xMt2 > 0 Then If xMt2 = 1 Then xPart2 = "mille " Else xPart2 = CONVERTIR(xMt2, " Mille") End If End If If xMt3 > 0 Then xPart3 = CONVERTIR(xMt3, "") End If If xMt4 > 0 Then xPart4 = CONVERTIR(xMt4, "") End If 'traitement de l' orthographe If pUPE <> "" Then pUPE = " " & pUPE If xDH = 0 Then If SI_0_Zero = True Then pUPE = "Zéro" & pUPE Else pUPE = "" End If End If If xDH > 1 Then pUPE = pUPE & "s" End If If pUPD <> "" Then pUPD = " " & pUPD If xCT = 0 Then If SI_0_Zero = True Then pUPD = " Zéro" & pUPD Else pUPD = "" End If End If If xCT > 1 Then pUPD = pUPD & "s" End If 'concaténation et retour de la chaine CONVERTION = xPart1 & xPart2 & xPart3 & pUPE & xPart4 & pUPD Exit Function ERR_CURR: MsgBox Err.Description End Function Public Function CONVERTIR(xNombre As Integer, xAdject As String) As String CONVERTIR = "" If xNombre = 0 Then Exit Function Dim A(19) As String 'tableau littéral de un à dix neuf Dim B(9) As String 'tableau littéral des dixaines Dim xChaine As String Dim i As Integer Dim J As Integer Dim k As Integer Dim jk As Integer Dim cAdject As String cAdject = "" cAdject = xAdject A(1) = " Un" A(2) = " Deux" A(3) = " Trois" A(4) = " Quatre" A(5) = " Cinq" A(6) = " Six" A(7) = " Sept" A(8) = " Huit" A(9) = " Neuf" A(10) = " Dix" A(11) = " Onze" A(12) = " Douze" A(13) = " Treize" A(14) = " Quatorze" A(15) = " Quinze" A(16) = " Seize" A(17) = " Dix-Sept" A(18) = " Dix-Huit" A(19) = " Dix-Neuf" B(1) = " Dix" B(2) = " Vingt" B(3) = " Trente" B(4) = " Quarante" B(5) = " Cinquante" B(6) = " Soixante" B(7) = " Soixante-Dix" B(8) = " Quatre-Vingt" B(9) = " Quatre-Vingt-Dix" 'décomposition du nombre i = xNombre \ 100 jk = (xNombre Mod 100) J = jk \ 10 k = jk Mod 10 If i > 0 Then If i = 1 Then xChaine = "Cent" Else xChaine = A(i) + " Cent" End If End If If jk = 0 Then If i > 1 And cAdject = "" Then xChaine = xChaine + "s" End If ElseIf jk = 1 Then xChaine = xChaine + A(k) ElseIf jk > 1 And jk < 10 Then xChaine = xChaine + A(k) ElseIf jk >= 10 And jk < 20 Then xChaine = xChaine + A(jk) Else If k = 0 Then xChaine = xChaine + B(J) If J = 8 Then If cAdject = "" Then xChaine = xChaine + "s" End If End If Else If J = 7 Or J = 9 Then If k = 1 Then xChaine = xChaine + B(J - 1) + " et " + A(11) Else xChaine = xChaine + B(J - 1) + A(10 + k) End If Else If k = 1 Then xChaine = xChaine + B(J) + " Et Un" Else xChaine = xChaine + B(J) + A(k) End If End If End If End If CONVERTIR = xChaine + cAdject End Function '/////////////////////////////////////////////////////////////////// Private Sub cmdOk_Click() On Error GoTo ERR_TEXT Text2.Text = CONVERTION(Text1.Text, "Euro", "Ct", True) Exit Sub ERR_TEXT: MsgBox Err.Description End Sub Private Sub Text1_GotFocus() Text2.Text = "" Text1.Alignment = 0 End Sub Private Sub Text1_KeyPress(KeyAscii As Integer) 'ici pourrait être insérer le control 'sur les chiffres End Sub Private Sub Text1_Validate(Cancel As Boolean) Dim cValue As Currency On Error GoTo ERR_CUR 'tester si le teste entré peut être convertit en monétaire 'test superflux puisque la fonction le fait. cValue = CCur(Text1.Text) With Text1 .Text = Format(.Text, "### ### ##0.00") .Alignment = 1 End With Exit Sub ERR_CUR: MsgBox Err.Description Cancel = True End Sub
;o)--
«Ce que l'on conçoit bien s'énonce clairement, Et les mots pour le dire arrivent aisément.»
Nicolas Boileau