Macro pour limitation de caractère et suppression du "en trop"

Bonjour,

Je viens ici afin d'espérer avoir la fameuse aide de vos talent d’algorithme.

J'ai déjà trouvé des macro qui correspondent à moitié a mes attentes mais malheureusement pas complément.

Je vous explique tout:

Je souhaite limiter mon texte dans les cellules d'une plage à 60 caractères et que le macro supprime les mots qui font que l'on a mis trop de caractère (que ça ne coupe donc pas le mot qu'il le supprime totalement). Ou alors encore mieux mais je ne sais pas si cela est possible, qu'il empêche d'écrire plus de caractère une fois atteint les 60.

Comme je le disais j'ai déjà trouvé un macro qui correspond à la limitation des caractères mais pas à la suppression des mots en trop (ou de l’empêchement d’écrire) mais celui ci fait descendre les mots en trop dans la cellule en dessous or cela ne m'arrange pas du tout

Voici le macro :

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Count <> 1 Then Exit Sub
If Application.Intersect(Range("F9:F38"), Target) Is Nothing Then Exit Sub
Dim maxLen As Integer, tabStr, i As Integer, tempStr
maxLen = 60

tabStr = Split(Target.Value, " ")
tempStr = ""
For i = LBound(tabStr) To UBound(tabStr)
    If Len(tempStr & " " & tabStr(i)) < maxLen Then
        If tabStr(i) <> "" Then tempStr = tempStr & " " & tabStr(i)
    Else
        If tempStr = "" Then tempStr = tabStr(i)
        tempStr = Right(tempStr, Len(tempStr) - 1)
        Target.Offset(1, 0).Value = Mid(Target.Value, Len(tempStr) + 2, Len(Target.Value) - Len(tempStr)) & " " & Target.Offset(1, 0).Value
        Target.Value = tempStr
        i = UBound(tabStr) + 1
    End If
Next i
End Sub

Donc avez vous la possibilité de modifier ce code afin qu'il empêche d'écrire au delà de 60 caractères ou sinon qu'il supprime les mots en trop ?

Ce serait vraiment super si vous sachiez faire cela ^^

Je vous remercie par avance.

Bonsoir,

Un exemple avec limitation de caractères en colonne A :

Private Sub Worksheet_Change(ByVal Target As Range)
 If Not Application.Intersect(Target, Range("A:A")) Is Nothing Then
 On Error Resume Next
For Each c In Target
If Len(c) > 60 Then
MsgBox "Limite de caractères atteinte"
c.Value = Left(c.Value, 60)
End If
Next c
End If
End Sub

En espérant que cela t'aide,

Cordialement,

Bonsoir, Salut xorsankukai !

Une procédure pour limiter à 60 caractères, sans couper de mot :

Private Sub Worksheet_Change(ByVal Target As Range)
    Const Lmax As Integer = 60
    Dim tx$, h%
    If Target.Count > 1 Then Exit Sub
    tx = Target
    If Len(tx) > Lmax Then
        tx = Left(tx, Lmax + 1)
        If Mid(tx, Len(tx), 1) = " " Then
            tx = RTrim(tx)
        Else
            h = InStrRev(tx, " ") - 1
            tx = Left(tx, h)
        End If
        Target = tx
    End If
End Sub

NB- J'ai mis la longueur max. voulue en constante Lmax en début de procédure. Si on veut changer cette longueur max. il suffit de modifier la valeur de cette constante.

Je n'ai pas repris la limitation à une plage, qui était F9:F38 dans ton code cité. Si cette limitation correspond à une choix de ta part, tu rétabliras cette condition. Si tu limites à une plage autre, tu définiras cette limitation de la même façon.

Cordialement.

Merci pour vos 2 réponses (quelle réactivité et efficacité, bravo)

Ta technique xorsankukai marche nickel, il y a juste que le mot ai coupé plutôt que d'être carrément effacé.

Cependant pour la tienne MFerrand, j'ai beau l'intégrer (seul bien sur, pas avec celle de xorsankukai ^^) ça ne le prend pas en compte dans le document, par ailleurs le fait de l'appliquer sur le plage F9:F38 était une volonté de ma part, mais n'étant pas du tout doué dans ce genre d'exercice je ne vois pas où rajouté dans le code la zone d'effet du macro (j'ai beau essayer, ça me met toujours une erreur).

Encore une fois merci, je sais pas comment vous faites pour faire des macro aussi simplement et rapidement, chapeau.

Tu rétablis ta ligne limitative avant la ligne : tx = Target

Mais l'absence de limitation ne l'empêche pas de fonctionner, elle fonctionne pour toutes les cellules, lors de la validation de ta saisie.

Bonjour,

Merci Mferrand pour ton intervention , ça parait si simple pour toi

Donc pour notre camarade minrae994, ça doit donner :

Private Sub Worksheet_Change(ByVal Target As Range)
    Const Lmax As Integer = 60
    Dim tx$, h%
    If Target.Count > 1 Then Exit Sub
    If Not Application.Intersect(Target, Range("F9:F38")) Is Nothing Then
    tx = Target
    If Len(tx) > Lmax Then
        tx = Left(tx, Lmax + 1)
        If Mid(tx, Len(tx), 1) = " " Then
            tx = RTrim(tx)
        Else
            h = InStrRev(tx, " ") - 1
            tx = Left(tx, h)
        End If
        Target = tx
    End If
    End If
End Sub

Cordialement,

Bonjour à vous 2,

Ce que vous venez de faire est super bien, ça marche nickel (exactement ce que j’espérais obtenir). Encore une fois merci et je ne sais pas comment vous faites pour faire ce genre de chose j'ai beau me plonger dans les algorithme de la VBA d'excel, je ne pige jamais rien dès qu'il faut faire plus de 3 actions .

Donc merci beaucoup pour votre réactivité c'est super et j'espère que je pourrais vous venir en aide un autre jour pour un autre problème qui sait .

Bon week-end à vous

Salut xorsankukai !

Oui. Ou il peut reprendre sa formulation initiale qui lui évite de rajouter un End If :

    If Intersect(Range("F9:F38"), Target) Is Nothing Then Exit Sub

Ou bien, il peut fusionner avec ta proposition de traitement de plusieurs cellules (Target pouvant être multicellulaire). Dans ce cas il supprime la limitation à 1 cellule : If Target.Count > 1 Then Exit Sub

et cela deviendrait :

Private Sub Worksheet_Change(ByVal Target As Range)
    Const Lmax As Integer = 60
    Dim tx$, h%, isect As Range, c As Range
    Set isect = Intersect(Range("F9:F38"), Target)
    If Not isect Is Nothing Then
        For Each c In isect
            tx = c.Value
            If Len(tx) > Lmax Then
                tx = Left(tx, Lmax + 1)
                If Mid(tx, Len(tx), 1) = " " Then
                    tx = RTrim(tx)
                Else
                    h = InStrRev(tx, " ") - 1
                    tx = Left(tx, h)
                End If
                c.Value = tx
            End If
        Next c
    End If
End Sub

La proc. fonctionnerait toujours pour la saisie, mais également en cas de collage sur 2 ou plusieurs cellules...

Cordialement. Bon weekend.