XL 2013 couper un texte par des saut de ligne sans couper les mots

patricktoulon · 15 Février 2021

bonjour a tous
je reviens un peu sur une curiosité
j'ai une chaine de mots
quelque soit la longueur je souhaite couper cette chaîne par lignes de X caractères (OU MOINS!!) sans couper les mots
dans la boucle je fait donc des jump en avant avec instr ou je reviens en arrière si la longueur dépasse X
tout du moins c'est ce que je pensais mais visiblement je rate quelque chose
pour ce faire j'utilise soit une boucle do/loop soir une for/next avec jumping par le instr
modele do/loop

VB:

Sub test()
    Dim x&, y&, oldpos, a&
    t = "aaaa bbbb cccc dddd ee fff ggg hhhhhh iiii jj kkkk lll mmmmm nnn oo ppp qqqqq rrrrr ssssss tttt uuuuu vv www x yy zzz"

    x = 0: y = 0
    Do While x < Len(t)

        x = InStr(y + 1, t, " ", vbTextCompare)

        If x = 0 Then Exit Do

        y = y + x

        a = x

        If (y - oldpos) > 30 Then x = InStrRev(Mid(t, 1, y), " ")

        oldpos = y = y - a + x

        Mid$(t, x, 1) = "*"

    Loop

    MsgBox t & vbCrLf & "----------------------" & vbCrLf & Replace(t, "*", vbCrLf)

End Sub

modele for/next

Code:

Sub test2()
    Dim oldpos&, i&, t$
    
    t = "aaaa bbbb cccc dddd ee fff ggg hhhhhh iiii jj kkkk lll mmmmm nnn oo ppp qqqqq rrrrr ssssss tttt uuuuu vv www x yy zzz"
    
    oldpos = 0
    
    For i = 1 To Len(t)
        
        i = InStr(oldpos + 1, t, " ", vbTextCompare)    'jump en avant
        
        If i = 0 Then Exit For    'sortie après la  dernière occurrence de " "
        
        If i - oldpos > 30 Then i = InStrRev(Mid(t, 1, i), " ")    'jump en arriere
        
        oldpos = i    'memo old position
        
        Mid$(t, i, 1) = "*"
    Next
 MsgBox t & vbCrLf & "----------------------" & vbCrLf & Replace(t, "*", vbCrLf)
End Sub

mais ou donc je rate le coche ?

pierrejean · 15 Février 2021

Re
correction de mon code

VB:

Sub essai()
 t = "aaaa bbbb cccc dddd ee fff ggg hhhhhh iiii jj kkkk lll mmmmm nnn oo ppp qqqqq rrrrr ssssss tttt uuuuu vv www x yy zzz"
 
While Len(t) >= 30
 If Mid(t, 31, 1) = " " Then
  res = res & Left(t, 30) & vbCrLf
  t = Mid(t, 31)
 Else
   x = Mid(t, 1, 30)
   y = InStrRev(x, " ")
   res = res & Left(x, y) & vbCrLf
   t = Trim(Mid(t, y))
  End If
Wend
Range("A2") = res & t
End Sub

sylvanu · 15 Février 2021

Bonjour Patrick,
Pas trouvé où ça cloche, désolé. J'ai l'impression que c'est le jonglage des pointeurs qui pose problème ( a ,x ,y ,oldpos ) mais impossible de mettre le doigt dessus.

Mais comme l'exercice de style est sympathique, pour le fun j'ai essayé cela :

VB:

Sub test()
    Dim Chaine$, ChaineR$, Nbcar%, NbCarMax%, i%
    Chaine = "aaaa bbbb cccc dddd ee fff ggg hhhhhh iiii jj kkkk lll mmmmm nnn oo ppp qqqqq rrrrr ssssss tttt uuuuu vv www x yy zzz"
    Nbcar = 0: NbCarMax = 30            ' NbCarMax : Nombre de caractères max par ligne
    t = Split(Chaine, " ")
    For i = 0 To UBound(t)
        Nbcar = Nbcar + Len(t(i)) + 1   ' +1 pour compter l'espace manquant dû au Split
        If Nbcar > NbCarMax Then
            t(i) = vbCrLf & t(i)        ' Ajout du saut de ligne car NbCarMax dépassé
            Nbcar = Len(t(i)) - 1       ' Ré init de Nbcar avec le dernier élement, -1 pour ne pas compter le vbCrLf
        End If
        ChaineR = ChaineR & t(i) & " "  ' Concaténation de la chaine de retour
    Next i
    MsgBox ChaineR
End Sub

pierrejean · 15 Février 2021

Bonjour Patrick
Salut Sylvanu
Voila ce que j'ai concocté (pas vu moi non plus ou ca cloche !!!)
NB: Voir un peu plus loin version corrigée

VB:

Sub essai()
t = "aaaa bbbb cccc dddd ee fff ggg hhhhhh iiii jj kkkk lll mmmmm nnn oo ppp qqqqq rrrrr ssssss tttt uuuuu vv www x yy zzz"
While Len(t) >= 30
   x = Mid(t, 1, 30)
   y = InStrRev(x, " ")
   res = res & Left(x, y) & vbCrLf
   t = Trim(Mid(t, y))
Wend
Range("A2") = res & t
End Sub

zebanx · 15 Février 2021

Bonjour PatrickToulon , Sylvanu, PierreJean, le forum

Un essai avec INT (de ma compréhension)

VB:

Sub test3()
    Dim oldpos&, i&, t$
   
    t = "aaaa bbbb cccc dddd ee fff ggg hhhhhh iiii jj kkkk lll mmmmm nnn oo ppp qqqqq rrrrr ssssss tttt uuuuu vv www x yy zzz"
   
    oldpos = 0
    k = 1
   
    For i = 1 To Len(t)
       
        i = InStr(oldpos + 1, t, " ", vbTextCompare)    'jump en avant
       
        If i = 0 Then Exit For    'sortie après la  dernière occurrence de " "
       
        If Int(i / (30 * k)) > 0 Then Mid$(t, i, 1) = "*": k = k + 1        
        oldpos = i    'jump en arriere
       
           'memo old position
               
    Next
MsgBox t & vbCrLf & "----------------------" & vbCrLf & Replace(t, "*", vbCrLf)
End Sub

sylvanu · 15 Février 2021

Re,
@patrick,
Je pense avoir trouvé. Le Mid$(t, i, 1) = "*" est indépendant de toute conditions, c'est pour ça qu'au début par ex on se retrouve avec aaaa*.
Ci dessous un truc qui semble marcher :

VB:

Sub test2()
    Dim x&, y&, oldpos, a&
    t = "aaaa bbbb cccc dddd ee fff ggg hhhhhh iiii jj kkkk lll mmmmm nnn oo ppp qqqqq rrrrr ssssss tttt uuuuu vv www x yy zzz"

    x = 0: y = 0
    Do While x < Len(t)
    
        x = InStr(y + 1, t, " ", vbTextCompare)
        If x = 0 Then Exit Do
        y = y + x
        a = x
        If (y - oldpos) > 30 Then
            x = InStrRev(Mid(t, 1, y), " ")
            Mid$(t, x, 1) = "*"                 ' l' * est rajouté uniquement si >30
        End If
        oldpos = y = y - a + x

    Loop
    MsgBox t & vbCrLf & "----------------------" & vbCrLf & Replace(t, "*", vbCrLf)
End Sub

TooFatBoy · 15 Février 2021

Bonjour,

Est-ce que le 30 ne devrait pas intervenir dans l'affectation de x ? Sinon tu vas te retrouver avec le 1er espace trouvé (position 5, et donc avec "aaaa ") ?

pierrejean · 15 Février 2021

Re
correction de mon code

VB:

Sub essai()
 t = "aaaa bbbb cccc dddd ee fff ggg hhhhhh iiii jj kkkk lll mmmmm nnn oo ppp qqqqq rrrrr ssssss tttt uuuuu vv www x yy zzz"
 
While Len(t) >= 30
 If Mid(t, 31, 1) = " " Then
  res = res & Left(t, 30) & vbCrLf
  t = Mid(t, 31)
 Else
   x = Mid(t, 1, 30)
   y = InStrRev(x, " ")
   res = res & Left(x, y) & vbCrLf
   t = Trim(Mid(t, y))
  End If
Wend
Range("A2") = res & t
End Sub

patricktoulon · 15 Février 2021

wiwh!! merci les gars je vais examiner reponse par réponse
j'ai du partir en urgence cet aprem donc je reviens la tete froide

déjà
1° @sylvanu
ta 1ere reponse non je veux pas split justement sinon trop facile
ta 2d ben bien sur bien évidement j'avais pas inclu le mid (applicatif)dans le IF (bien vu)
mais j'ai des lignes de plus de 30 caracteres

@pierrejean ; ben çà a l'air bon tout ça j'ai pas bien compris le procc mais bon je vais examiner
un seul soucis l'espace devant sur certaines lignes

et alors le ponpon
@zebanx c'est pas mal mais on est a 31 caractères au lieu de 30 ou moins

patricktoulon · 15 Février 2021

ok en trimant le t restant celle de pierre jean est bonne
parcontre ce que je ne pige pas c'est le 1er a 30 d'office alors que l'on sait pas encore si c'est bon
edit ok pigé c'est dans un if

VB:

Sub essai()
t = "aaaaaaa bbbbbbbb cccc dddd ee fff ggg hhhhhh iiii jj kkkk lll mmmmm nnn oo ppp qqqqq rrrrr ssssss tttt uuuuu vv www x yy zzz"

While Len(t) >= 30
If Mid(t, 31, 1) = " " Then
  res = res & Trim(Left(t, 30)) & vbCrLf
  t = Trim(Mid(t, 31))
Else
   x = Mid(t, 1, 30)
   y = InStrRev(x, " ")
   res = res & Trim(Left(x, y)) & vbCrLf
   t = Trim(Mid(t, y))
  End If
Wend
MsgBox res & t
End Sub

zebanx · 15 Février 2021

Re-

@patricktoulon
Je n'ai pas compris ta remarque.
La coupure se fait au choix sur un paramètre Int(i / (30 * k))
Par exemple avec 20 :

La modification est minime sur ton code de départ.
Et comme souvent sur ED, les solutions variées sont appréciables !
La demande de départ ne l'est d'ailleurs pas moins

patricktoulon · 15 Février 2021

@zebanx
sur la base de @zebanx
il y a quelque chose qui déraille quelque part il coupe trop petit

VB:

Sub zebanx()
Dim T$, L&
    T = [A1].Value
    L = Int([A1].ColumnWidth)
    T = WrappWithAjustEntireWord2(T, L)
    tb = Split(T, vbCrLf)
    For i = 0 To UBound(tb): tb(i) = tb(i) & "-->" & Len(tb(i)) & " char": Next: T = Join(tb, vbCrLf)
    MsgBox T
End Sub
Function WrappWithAjustEntireWord2(ByVal T$, ByVal L&)
    Dim oldpos&, i&
    oldpos = 0
    k = 1
    For i = 1 To Len(T)
        i = InStr(oldpos + 1, T, " ", vbTextCompare)    'jump en avant
        If i = 0 Then Exit For    'sortie après la  dernière occurrence de " "
        If Int(i / (l* k)) > 0 Then Mid$(T, i, 1) = "*": k = k + 1
        oldpos = i    'memo old position
    Next
   If Asc(Mid(T, Len(T))) = 10 Then T = Left(T, Len(T) - 1)
   WrappWithAjustEntireWord2 = Replace(T, "*", vbCrLf)
End Function

sur la base de @pierrejean
elle fonctionne impec quelque soit la largeur de colonne
ps: il faut pas descendre en dessous du mot le plus long de la haine bien sur

VB:

Sub test()
    Dim T$, L&
    T = [A1].Value
    L = Int([A1].ColumnWidth)
    T = WrappWithAjustEntireWord(T, L)
    tb = Split(T, vbCrLf)
    For i = 0 To UBound(tb): tb(i) = tb(i) & "-->" & Len(tb(i)) & " char": Next: T = Join(tb, vbCrLf)
    MsgBox T
    '[A1]=t
End Sub

Function WrappWithAjustEntireWord(ByVal T$, ByVal L&)
    Dim Res$, X$, Y&
    While Len(T) >= L
        If Mid(T, L + 1, 1) = " " Then
            Res = Res & Trim(Left(T, L)) & vbCrLf
            T = Trim(Mid(T, L + 1))
        Else
            X = Mid(T, 1, L)
            Y = InStrRev(X, " ")
            Res = Res & Trim(Left(X, Y)) & vbCrLf
            T = Trim(Mid(T, Y))
        End If
    Wend
    If Asc(Mid(T, Len(T))) = 10 Then T = Left(T, Len(T) - 1)
    WrappWithAjustEntireWord = Res & T
End Function

Code:

sub pourTest()
[A1].columnwidth=20
[A1]="aaaaaaaaaaaaaaaaaa bbbbbbbb cccc dddd ee fff ggg hhhhhh iiii jj kkkk lll mmmmm nnn oo ppp qqqqq rrrrr ssssss tttt uuuuu vv www x yy zzz"
end sub

mapomme · 15 Février 2021

Bonsoir,

Intéressé par la question, j'ai comparé 4 méthodes :

celle de sylvanu (avec modif d'une ligne de ma part pour éviter le retour à la ligne du début)
celle de pierrejean (version corrigée)
celle de zebanx
celle de patricktoulon (version modifiée de pierre jean)

Les méthodes 2 et 4 boguent quand un "mot" dépasse le nombre de caractères pour la césure
La méthode n° 3 me donne un résultat bizarre (j'ai peut-être mal retranscrit la méthode)
La méthode 1 semble donner le bon résultat yc pour des mots "longs"

nota : avant de traiter le texte, je l'ai passé au "Supprespace"

patricktoulon · 15 Février 2021

@mapomme
et ben !!!...encore une fois t'a pris ton temps toi hein!!!

oui la modif de zebanx donne un résultat bizarre en effet
c'est quand même étonnant chez moi c'est celle de @pierrejean qui fonctionne impec

mapomme · 15 Février 2021

patricktoulon à dit:
et ben !!!...encore une fois t'a pris ton temps toi hein!!!

Salut Patrick
Le temps c'est de l'argent. J'en ai pris beaucoup du temps donc je suis riche . Et pourtant je ne le suis pas .

patricktoulon · 15 Février 2021

essaie ma fonction sur la base de pierrejean c'est nikel il faut bien entendu qu'il n'y ai pas un mot plus grand que le round du columnwidth bien sur
il faut que je trouve un truc pour eviter cette erreur sans alourdir la fonction

XL 2013 couper un texte par des saut de ligne sans couper les mots

patricktoulon

XLDnaute Barbatruc

pierrejean

sylvanu

XLDnaute Barbatruc

pierrejean

XLDnaute Barbatruc

zebanx

XLDnaute Accro

sylvanu

XLDnaute Barbatruc

TooFatBoy

XLDnaute Barbatruc

pierrejean

XLDnaute Barbatruc

patricktoulon

XLDnaute Barbatruc

patricktoulon

XLDnaute Barbatruc

zebanx

XLDnaute Accro

patricktoulon

XLDnaute Barbatruc

mapomme

XLDnaute Barbatruc

Pièces jointes

patricktoulon

XLDnaute Barbatruc

mapomme

XLDnaute Barbatruc

patricktoulon

XLDnaute Barbatruc