Microsoft Visual Basic

Résolu
DJAMALOS -  
Bonjour,

Microsoft Visual Basic
Comment créer ou ajouter une fonction dans Visual Basic Retour à la ligne dans excel 2007
Exemple :Quatre Mille Dinars (Retour à la ligne)
Et 03 Centimes
Mille Merci

11 réponses

  1.  DJAMALOS Auteur
    Bonjour Michel
    voila ca n'a tjrs pa fonctionné, voici un exemple et mille merci pour avoir donné un peux de votre temps et votre aide.

    http://www.cijoint.fr/cjlink.php?file=cj201101/cijyuwRI2o.xls
    0
    1. mic13710
      Bonsoir,

      Ca ne marche pas parce que vous n'avez pas autorisé le renvoi à la ligne de la cellule comme je vous l'avais indiqué.

      Reprenez mon message. J'ai écrit :
      "Et pour que l'affichage se fasse sur 2 lignes, il faut autoriser le renvoi à la ligne dans la cellule, sinon, c'est un carré qui s'affiche. "
      Or vous avez un carré dans votre exemple.

      Pour afficher sur 2 lignes : Format/Cellule/Alignement, cliquer sur "Renvoyer à la ligne automatiquement"
      C'est obligatoire si vous voulez le résultat sur 2 lignes.
      Et pour pérenniser ce format sur votre document, je vous conseille aussi de régler sur ce même onglet le positionnement vertical sur "Centré".
      Enfin, il faut aussi régler la hauteur de la ligne à 32 pour être sûr que l'affichage pourra se faire sur 2 lignes. (Format/Ligne/Hauteur)

      J'ai cherché une méthode pour que ce réglage se fasse automatiquement suivant la devise sélectionnée, sans succès. Il semble impossible de modifier la hauteur de ligne sur le résultat d'une fonction publique. Mais je me trompe peut-être.

      En attendant, si vous faites les réglages que je vous ai indiqué, votre montant en Dinar apparaîtra sur 2 lignes comme vous le souhaitez. Les autres montants seront affichés dans le même cadre au centre sur une ligne.

      Quant à mettre les centimes en chiffres (votre remarque sur votre exemple), il faudrait encore rechercher les lignes à modifier ce qui n'est pas simple, et c'est à mon avis un travail peu utile qui risquerait de perturber le bon fonctionnement de la macro.

      Petite modification à effectuer sur votre macro :

      Supprimer celle-ci en gras demandé dans mon dernier post : 
      .........   
Exit Function   
End If   
End If   
If Devise > 3 Then Devise = 0   
Select Case Devise   
Case 0   
If byDec > 0 Then strDev = " et "   
Case 1   
...........

      Et insérer ces lignes en gras : 

      Public Function ConvNumberLetter(Nombre As Double, Optional Devise As Byte = 2, _   
Optional Langue As Byte = 0, _   
Optional Casse As Byte = 3, _   
Optional ZeroCent As Byte = 0) As String   
Dim dblEnt As Variant, byDec As Byte   
Dim bNegatif As Boolean   
Dim strDev As String, strCentimes As String   

If Nombre < 0 Then   
bNegatif = True   
Nombre = Abs(Nombre)   
End If   
If Devise > 3 Then Devise = 2   
If Langue > 2 Then Langue = 0   
If Casse > 3 Then Casse = 3   
dblEnt = Int(Nombre)   
byDec = CInt((Nombre - dblEnt) * 100)

      C'est pour éviter de rentrer des valeurs hors plage de saisie. Les valeurs sont alors mises par défaut.

      Michel
      0
    2. mic13710
      Y'a pas de quoi !
      (une réponse serait la bienvenue et si c'est ok merci de passer le sujet comme résolu)
      0
  2. DJAMALOS Auteur
    Mytå
    Bonjour j'attends votre aide Merci
    0
    1. DJAMALOS Auteur
      Michel
      voici le code complet
      Option Explicit

      '***********
      ' Devise=0 aucune
      ' =1 Euro €
      ' =2 Dinar DA
      ' =3 €uro €
      ' Langue=0 Français
      ' =1 Belgique
      ' =2 Suisse
      ' Casse =0 Minuscule
      ' =1 Majuscule en début de phrase
      ' =2 Majuscule
      ' =3 Majuscule en début de chaque mot
      ' ZeroCent=0 Ne mentionne pas les cents s'ils sont égal à 0
      ' =1 Mentionne toujours les cents
      '***********
      ' Conversion limitée à 999 999 999 999 999 ou 9 999 999 999 999,99
      ' si le nombre contient plus de 2 décimales, il est arrondit à 2 décimales

      Public Function ConvNumberLetter(Nombre As Double, Optional Devise As Byte = 2, _
      Optional Langue As Byte = 0, _
      Optional Casse As Byte = 3, _
      Optional ZeroCent As Byte = 0) As String
      Dim dblEnt As Variant, byDec As Byte
      Dim bNegatif As Boolean
      Dim strDev As String, strCentimes As String

      If Nombre < 0 Then
      bNegatif = True
      Nombre = Abs(Nombre)
      End If
      dblEnt = Int(Nombre)
      byDec = CInt((Nombre - dblEnt) * 100)
      If byDec = 0 Then
      If dblEnt > 999999999999999# Then
      ConvNumberLetter = "#TropGrand"
      Exit Function
      End If
      Else
      If dblEnt > 9999999999999.99 Then
      ConvNumberLetter = "#TropGrand"
      Exit Function
      End If
      End If
      Select Case Devise
      Case 0
      If byDec > 0 Then strDev = " et "
      Case 1
      strDev = " Euro"
      If dblEnt >= 1000000 And Right(dblEnt, 6) = "000000" Then strDev = " d'Euro"
      If byDec > 0 Then strCentimes = strCentimes & " Cent"
      If byDec > 1 Then strCentimes = strCentimes & "s"
      Case 2
      strDev = " Dinar"
      If byDec > 0 Then strCentimes = strCentimes & " Cts"
      Case 3
      strDev = " €uro"
      If dblEnt >= 1000000 And Right(dblEnt, 6) = "000000" Then strDev = " d'€uro"
      If byDec > 0 Then strCentimes = strCentimes & " Cent"
      If byDec > 1 Then strCentimes = strCentimes & "s"
      End Select
      If dblEnt > 1 And Devise <> 0 Then strDev = strDev & "s"
      strDev = strDev & " "
      If dblEnt = 0 Then
      ConvNumberLetter = "zéro " & strDev
      Else
      ConvNumberLetter = ConvNumEnt(CDbl(dblEnt), Langue) & strDev
      End If
      If byDec = 0 Then
      If Devise <> 0 Then
      If ZeroCent = 1 Then ConvNumberLetter = ConvNumberLetter & "zéro Cent"
      End If
      Else
      If Devise = 0 Then
      ConvNumberLetter = ConvNumberLetter & _
      ConvNumDizaine(byDec, Langue, True) & strCentimes
      Else
      ConvNumberLetter = ConvNumberLetter & _
      ConvNumDizaine(byDec, Langue, False) & strCentimes
      End If
      End If
      ConvNumberLetter = Replace(ConvNumberLetter, " ", " ")
      If Left(ConvNumberLetter, 1) = " " Then ConvNumberLetter = _
      Right(ConvNumberLetter, Len(ConvNumberLetter) - 1)
      If Right(ConvNumberLetter, 1) = " " Then ConvNumberLetter = _
      Left(ConvNumberLetter, Len(ConvNumberLetter) - 1)
      Select Case Casse
      Case 0
      ConvNumberLetter = LCase(ConvNumberLetter)
      Case 1
      ConvNumberLetter = UCase(Left(ConvNumberLetter, 1)) & _
      LCase(Right(ConvNumberLetter, Len(ConvNumberLetter) - 1))
      Case 2
      ConvNumberLetter = UCase(ConvNumberLetter)
      Case 3
      ConvNumberLetter = Application.WorksheetFunction.Proper(ConvNumberLetter)
      If Devise = 3 Then _
      ConvNumberLetter = Replace(ConvNumberLetter, "€Uros", "€uros", , , vbTextCompare)
      End Select
      End Function

      Private Function ConvNumEnt(Nombre As Double, Langue As Byte)
      Dim iTmp As Variant, dblReste As Double
      Dim strTmp As String
      Dim iCent As Integer, iMille As Integer, iMillion As Integer
      Dim iMilliard As Integer, iBillion As Integer

      iTmp = Nombre - (Int(Nombre / 1000) * 1000)
      iCent = CInt(iTmp)
      ConvNumEnt = Nz(ConvNumCent(iCent, Langue))
      dblReste = Int(Nombre / 1000)
      If iTmp = 0 And dblReste = 0 Then Exit Function
      iTmp = dblReste - (Int(dblReste / 1000) * 1000)
      If iTmp = 0 And dblReste = 0 Then Exit Function
      iMille = CInt(iTmp)
      strTmp = ConvNumCent(iMille, Langue)
      Select Case iTmp
      Case 0
      Case 1
      strTmp = " mille "
      Case Else
      strTmp = strTmp & " mille "
      End Select
      If iMille = 0 And iCent > 0 Then ConvNumEnt = "et " & ConvNumEnt
      ConvNumEnt = Nz(strTmp) & ConvNumEnt
      dblReste = Int(dblReste / 1000)
      iTmp = dblReste - (Int(dblReste / 1000) * 1000)
      If iTmp = 0 And dblReste = 0 Then Exit Function
      iMillion = CInt(iTmp)
      strTmp = ConvNumCent(iMillion, Langue)
      Select Case iTmp
      Case 0
      Case 1
      strTmp = strTmp & " million "
      Case Else
      strTmp = strTmp & " millions "
      End Select
      If iMille = 1 Then ConvNumEnt = "et " & ConvNumEnt
      ConvNumEnt = Nz(strTmp) & ConvNumEnt
      dblReste = Int(dblReste / 1000)
      iTmp = dblReste - (Int(dblReste / 1000) * 1000)
      If iTmp = 0 And dblReste = 0 Then Exit Function
      iMilliard = CInt(iTmp)
      strTmp = ConvNumCent(iMilliard, Langue)
      Select Case iTmp
      Case 0
      Case 1
      strTmp = strTmp & " milliard "
      Case Else
      strTmp = strTmp & " milliards "
      End Select
      If iMillion = 1 Then ConvNumEnt = "et " & ConvNumEnt
      ConvNumEnt = Nz(strTmp) & ConvNumEnt
      dblReste = Int(dblReste / 1000)
      iTmp = dblReste - (Int(dblReste / 1000) * 1000)
      If iTmp = 0 And dblReste = 0 Then Exit Function
      iBillion = CInt(iTmp)
      strTmp = ConvNumCent(iBillion, Langue)
      Select Case iTmp
      Case 0
      Case 1
      strTmp = strTmp & " billion "
      Case Else
      strTmp = strTmp & " billions "
      End Select
      If iMilliard = 1 Then ConvNumEnt = "et " & ConvNumEnt
      ConvNumEnt = Nz(strTmp) & ConvNumEnt
      End Function

      Private Function ConvNumDizaine(Nombre As Byte, Langue As Byte, bDec As Boolean) As String
      Dim TabUnit As Variant, TabDiz As Variant
      Dim byUnit As Byte, byDiz As Byte
      Dim strLiaison As String

      If bDec Then
      TabDiz = Array("zéro", "", "vingt", "trente", "quarante", "cinquante", _
      "soixante", "soixante", "quatre vingt", "quatre vingt")
      Else
      TabDiz = Array("", "", "vingt", "trente", "quarante", "cinquante", _
      "soixante", "soixante", "quatre vingt", "quatre vingt")
      End If
      If Nombre = 0 Then
      TabUnit = Array("zéro")
      Else
      TabUnit = Array("", "un", "deux", "trois", "quatre", "cinq", "six", "sept", _
      "huit", "neuf", "dix", "onze", "douze", "treize", "quatorze", "quinze", _
      "seize", "dix sept", "dix huit", "dix neuf")
      End If
      If Langue = 1 Then
      TabDiz(7) = "septante"
      TabDiz(9) = "nonante"
      ElseIf Langue = 2 Then
      TabDiz(7) = "septante"
      TabDiz(8) = "huitante"
      TabDiz(9) = "nonante"
      End If
      byDiz = Int(Nombre / 10)
      byUnit = Nombre - (byDiz * 10)
      strLiaison = " "
      If byUnit = 1 Then strLiaison = " et "
      Select Case byDiz
      Case 0
      strLiaison = " "
      Case 1
      byUnit = byUnit + 10
      strLiaison = " "
      Case 7
      If Langue = 0 Then byUnit = byUnit + 10
      Case 8
      If Langue <> 2 Then strLiaison = " "
      Case 9
      If Langue = 0 Then
      byUnit = byUnit + 10
      strLiaison = " "
      End If
      End Select
      ConvNumDizaine = TabDiz(byDiz)
      If byDiz = 8 And Langue <> 2 And byUnit = 0 Then ConvNumDizaine = ConvNumDizaine & "s"
      If TabUnit(byUnit) <> "" Then
      ConvNumDizaine = ConvNumDizaine & strLiaison & TabUnit(byUnit)
      Else
      ConvNumDizaine = ConvNumDizaine
      End If
      End Function

      Private Function ConvNumCent(Nombre As Integer, Langue As Byte) As String
      Dim TabUnit As Variant
      Dim byCent As Byte, byReste As Byte
      Dim strReste As String

      TabUnit = Array("", "un", "deux", "trois", "quatre", "cinq", "six", "sept", _
      "huit", "neuf", "dix")
      byCent = Int(Nombre / 100)
      byReste = Nombre - (byCent * 100)
      strReste = ConvNumDizaine(byReste, Langue, False)
      Select Case byCent
      Case 0
      ConvNumCent = strReste
      Case 1
      If byReste = 0 Then
      ConvNumCent = "cent"
      Else
      ConvNumCent = "cent " & strReste
      End If
      Case Else
      If byReste = 0 Then
      ConvNumCent = TabUnit(byCent) & " cents"
      Else
      ConvNumCent = TabUnit(byCent) & " cent " & strReste
      End If
      End Select
      End Function

      Private Function Nz(strNb As String) As String
      If strNb <> " zéro" Then Nz = strNb
      End Function

      Résultat trouvé :
      Cent Deux Mille Trois Cent Soixante Quinze Dinars Trente Neuf Cts

      tout est ok mais le vrai probleme c'est que je veux les Cts soient au dessous des dinars exemple :
      Cent Deux Mille Trois Cent Soixante Quinze Dinars (à ligne)
      Trente Neuf Cts (ou 39 Cts)
      Mille Merci
      0
      1. mic13710
        Je comprends mieux pourquoi ça ne marche pas : ce n'est pas un affichage direct d'une chaine comme on pouvait l'imaginer dans votre question, mais c'est une fonction autrement plus complexe que les simples lignes que vous nous avez présenté au départ.
        Et il y a du monde !
        Compte tenu de la complexité de votre code, il faut du temps pour comprendre tout le fonctionnement avant de pouvoir y apporter une solution.

        Il y a là en tout cas de quoi intéresser les amateurs de beaux codes !

        Michel
        0
      2. mic13710
        Après analyse de votre code ci-après en gras les lignes à ajouter dans la fonction publique : 

        If Devise = 0 Then
ConvNumberLetter = ConvNumberLetter & _
ConvNumDizaine(byDec, Langue, True) & strCentimes
ElseIf Devise = 2 Then
ConvNumberLetter = ConvNumberLetter & _
Chr(10) & ConvNumDizaine(byDec, Langue, False) & strCentimes
Else
ConvNumberLetter = ConvNumberLetter & _
ConvNumDizaine(byDec, Langue, False) & strCentimes
End If


        Et pour que l'affichage se fasse sur 2 lignes, il faut autoriser le renvoi à la ligne dans la cellule, sinon, c'est un carré qui s'affiche.

        Je vous signale aussi un problème sur le numéro de référence des devises. Il est possible de mettre un code > 3, auquel cas l'affichage inclus un s inutile et devient incompréhensible.
        Pour corriger, je propose de mettre la devise à 0 si la valeur saisie est supérieure à 3. Pour se faire, rajouter la ligne en gras avant le select case comme suit : 

        .........
Exit Function
End If
End If
If Devise > 3 Then Devise = 0
Select Case Devise
Case 0
If byDec > 0 Then strDev = " et "
Case 1
...........


        Cordialement,

        Michel
        0
    2. djamalos
      aucun, meme resultat exemple :
      toujours : mille dinars et soixante centimes
      au lieu
      de mille dinars
      et soixante centimes
      merci
      0
      1. mic13710
        Votre résultat ne colle pas avec votre code.
        Vous écrivez "Dinars" avec un s alors que votre code recherche "Dinar".
        Etes-vous sûr que votre strDev = "Dinar" est correct ?
        Si c'était le cas, votre résultat devrait être soixante Cts et non centimes.

        Pouvez-vous mettre la ou les lignes qui suivent votre code ou du moins celles qui servent à compiler le résultat ?

        Michel
        0
    4. djamalos
      Michel Bonjour
      Pardon pour retard absolument rien de changé
      ou dois-je mettre la ligne que vous m'avez conseillé et Merci
      0
      1. DJAMALOS Auteur
        j'ai essayer
        If byDec > 0 Then strCentimes = vbCrLf & strCentimes & " Cts"
        ca na rien donné merci comme meme
        0
        1. mic13710
          C'est à dire ?
          Quel résultat obtenez-vous ?
          0
      2. DJAMALOS Auteur
        Myta et Michel
        ca na rien donner autres proposition Merci
        0
        1. DJAMALOS Auteur
          Mytå
          Merci l'ami j'attends votre aide
          0
          1. DJAMALOS Auteur
            Merci Michel
            voici un exemple pour mieu vous expliquer
            Select Case Devise
            Case 0
            If byDec > 0 Then strDev = " et "
            Case 1
            strDev = " Euro"
            If dblEnt >= 1000000 And Right(dblEnt, 6) = "000000" Then strDev = " d'Euro"
            If byDec > 0 Then strCentimes = strCentimes & " Cent"
            If byDec > 1 Then strCentimes = strCentimes & "s"
            Case 2
            strDev = " Dinar"
            If byDec > 0 Then strCentimes = strCentimes & " Cts"
            Case 3
            strDev = " €uro"
            If dblEnt >= 1000000 And Right(dblEnt, 6) = "000000" Then strDev = " d'€uro"
            If byDec > 0 Then strCentimes = strCentimes & " Cent"
            If byDec > 1 Then strCentimes = strCentimes & "s"
            End Select

            a partir du dinar que je vous une Interligne (ou retour à la ligne) Merci
            0
            1. mic13710
              Essayez ça :

              If byDec > 0 Then strCentimes = Chr(10) & strCentimes & " Cts"

              Ou vbCrLf à la place de Chr(10) comme l'a proposé Myta

              Michel
              0
          2. Mytå Contributeur
            Salut le forum

            Avec un vbCrLf (carriage return + line feed)

            Range("A1") = "Texte 1" & vbCrLf & "Texte 2"

            Mytå
            0
            1. mic13710
              Salut,

              "Quatre Mille Dinars" & Chr(10) & "03 Centimes"

              Michel
              0

              Discussions similaires

              Site de confiance ou non ?
              mlle_so

              25 réponses