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

patricktoulon

XLDnaute Barbatruc
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 ? 🤔 🤯
 
Solution
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

XLDnaute Barbatruc
Supporter XLD
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

XLDnaute Barbatruc
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
 
Dernière édition:

zebanx

XLDnaute Accro
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

XLDnaute Barbatruc
Supporter XLD
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
 

pierrejean

XLDnaute Barbatruc
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

XLDnaute Barbatruc
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à
@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
 
Dernière édition:

patricktoulon

XLDnaute Barbatruc
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

XLDnaute Accro
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 :

1613405769991.png


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 :)
 
Dernière édition:

patricktoulon

XLDnaute Barbatruc
@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

XLDnaute Barbatruc
Supporter XLD
Bonsoir,

Intéressé par la question, j'ai comparé 4 méthodes :
  1. celle de sylvanu (avec modif d'une ligne de ma part pour éviter le retour à la ligne du début)
  2. celle de pierrejean (version corrigée)
  3. celle de zebanx
  4. 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"
 

Pièces jointes

  • patricktoulon- à la ligne- test- v1.xlsm
    21.2 KB · Affichages: 11

Statistiques des forums

Discussions
311 720
Messages
2 081 902
Membres
101 834
dernier inscrit
Jeremy06510