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

patricktoulon · 16 Février 2021

@laurent950
je dis pas que c'est pas bon j'en sais rien
mais fan de chique tu a vu l'usine que tu a fait pour mettre des saut de ligne
c'est bien continu essaie
mais j'ai ris un peu ça fait du bien

la logique la plus simple
x=0:y=1
boucle do tant que i<> 0
i= la position de l'espace suivant a partir de y ( instr)
si x -y > longueur voulue alors x = la position de l'espace précédant et donc y=x
donc y=x
sinon
si x -y = longueur voulue alors x = la position de l'espace on met le repère dans la chaine :donc y=x
retourne à do
t=remplace le repère par les saut de ligne dans T
tu n'a plus qu'a traduire ça en vba
pas compliqué

laurent950 · 16 Février 2021

patricktoulon à dit:
@laurent950
je dis pas que c'est pas bon j'en sais rien
mais fan de chique tu a vu l'usine que tu a fait pour mettre des saut de ligne
c'est bien continu essaie
mais j'ai ris un peu ça fait du bien

Merci Patrick je vais poursuivre, c'est assez complexe quand même comme code

patricktoulon · 16 Février 2021

@laurent950
non pas du tout
le code traduit toujours un raisonnement
quand le raisonnement est bon le transcrire en vba ou dans le langage que tu pratique est plus simple
je fait toujours comme ça quand je rame
je l’écrit en français d’abords (je te l'ai déjà dis me semble t il )

tiens une 6 eme puisque tu aime le split ben la voila dans une (on ne peut plus simple) méthode
c'est pour te dire a quel point tu t'est compliqué la vie

VB:

Sub testPat6()
    Dim T$, L&
    T = [A1].Text
    L = Int([A1].ColumnWidth)
    T = WrappWithAjustEntireWord6(T, L)
    If T <> "" Then
        tb = Split(T, vbCrLf)
        For i = 0 To UBound(tb): tb(i) = tb(i) & "-->" & Len(tb(i)) & " char": Next: T = Join(tb, vbCrLf)
        MsgBox "pour A1" & vbCrLf & T
    Else
        MsgBox "en A1" & vbCrLf & "un mot est trop long dans la chaine il depasse les " & L & " caracteres"
    End If


    T = [A2].Text
    T = WrappWithAjustEntireWord6(T, L)
    If T <> "" Then
        tb = Split(T, vbCrLf)
        For i = 0 To UBound(tb): tb(i) = tb(i) & "-->" & Len(tb(i)) & " char": Next: T = Join(tb, vbCrLf)
        MsgBox "pour A2" & vbCrLf & T
    Else
        MsgBox "en A2" & vbCrLf & "un mot est trop long dans la chaîne il dépasse les " & L & " caractères"
    End If

End Sub

Function WrappWithAjustEntireWord6(ByVal T$, ByVal L&)
    tb = Split(T, " ")
    For i = 0 To UBound(tb)
        If Len(tb(i)) > L Then WrappWithAjustEntireWord6 = "": Exit Function
        X = X + Len(tb(i)) + 1
        If X = L Then tb(i) = tb(i) & vbCrLf: X = 0
        If X > L Then X = Len(tb(i)): tb(i) = vbCrLf & tb(i):
    Next
    WrappWithAjustEntireWord6 = Join(tb, " ")
End Function

laurent950 · 16 Février 2021

Re @patricktoulon

Merci pour le partage de ce code très intéressant. pour ma part j'aurais essaie de faire quelque chose mais c'est pas si simple quand même. vous êtes un champion Patrick.
Félicitation pour cette solution

Merci Patrick

patricktoulon · 17 Février 2021

re
bonjour à tous
@laurent950
champion non mais je réfléchi
je ne vois pas que le but a court terme

et donc pour celle ci ,puisque c'est facile ,pour me remettre dans le bain de cette journée , tout doucement à la fraîche

la voila respectant les paragraphes existants
tu constatera que j'ai fait sauter la "condition x=L "je n'ai gardé que la " condition X>L"
car après tout ,elle était inutile

VB:

Function WrappWithAjustEntireWord6(ByVal T$, ByVal L&) As String
   Dim tbp, tb, a&, i&, x&
    tbp = Split(T, vbLf)
     For a = LBound(tbp) To UBound(tbp)
        x = 0: tb = Split(tbp(a), " ")
        For i = 0 To UBound(tb)
            x = x + Len(tb(i)) + 1: If Len(tb(i)) > L Then Exit Function
            If x > L Then x = Len(tb(i)): tb(i) = vbCrLf & tb(i):
        Next
        tbp(a) = Join(tb, " ")
    Next
    WrappWithAjustEntireWord6 = Join(tbp, vbCrLf)
End Function

et voila ma préférée le do/loop incrémentée par le instr
la aussi je fait sauter la condition x-oldpos=L

VB:

Function WrappWithAjustEntireWord1(ByVal T$, ByVal L&)
    Dim x&, OldPos&: x = 1: OldPos = 0
    tbp = Split(T, vbLf)
    For a = 0 To UBound(tbp)
       OldPos = 0: x = 1
        Do Until x = 0
            x = InStr(x + 1, tbp(a), " ")    'incrémentation par le instr
            If (x - OldPos) > L + 1 Then
                x = InStrRev(Mid(tbp(a), 1, x - 1), " ")    'retour en erriere
                If x + OldPos = 0 Then WrappWithAjustEntireWord1 = "": Exit Function    ' erreur declanchée quand il y a un mot plus grand que la longueur  demandée
                 If x = 0 Then Exit Function
               Mid$(tbp(a), x, 1) = "*": OldPos = x
            End If
        Loop
        Next a
WrappWithAjustEntireWord1 = Replace(Join(tbp, vbCrLf), "*", vbCrLf)
End Function

celle que j'aime moins (avec l'incrémentation numerique des pas de L)mais puisqu'on a travaillé dessus

VB:

Function WrappWithAjustEntireWord3(ByVal T$, ByVal L&)
     On Error Resume Next
   tbp = Split(T, vbLf)
   For a = 0 To UBound(tbp)
   i = 0
   Do Until i >= Len(tbp(a))
        i = i + L 'incrémentation numerique
        If i > Len(tbp(a)) Then Exit Do
        If Mid(tbp(a), i, 1) = " " Then
            Mid(tbp(a), i, 1) = "*"
        Else
            i = InStrRev(Mid(tbp(a), 1, i - 1), " "): Mid(tbp(a), i, 1) = "*"
            If Err.Number > 0 Then WrappWithAjustEntireWord3 = "": Exit Function
        End If
    Loop
    Next a
    If Err.Number = 0 Then temoins = True: WrappWithAjustEntireWord3 = Replace(Join(tbp, vbCrLf), "*", vbCrLf)
End Function

et enfin la version regex rien a dire (bonnet blanc blanc bonnet)

VB:

Function WrappWithAjustEntireWord5(ByVal T$, ByVal L&)
    Dim matchs, r$, tbp, a&, i&
    With CreateObject("VBScript.RegExp"):
        .Global = True: .IgnoreCase = True:
        tbp = Split(T, vbLf)
        For a = 0 To UBound(tbp)
            .Pattern = "([A-z-0-9]{" & L + 1 & "," & L + 20 & "})":
            Set matchs = .Execute(tbp(a))
            If matchs.Count > 0 Then WrappWithAjustEntireWord5 = "": Exit Function
            .Pattern = "(\D{1," & L & "})\s": Set matchs = .Execute(tbp(a))
            If matchs.Count > 0 Then
                For i = 0 To matchs.Count - 1: r = r & Trim(matchs(i)) & "-->" & Len(Trim(matchs(i))) & vbCrLf: Next
                tbp(a) = Trim(r) & IIf(a < UBound(tbp), vbCrLf, ""): r = ""
            End If
        Next a
        WrappWithAjustEntireWord5 = Join(tbp)
    End With
End Function

malheureusement les versions @pierrejean et @zebanx n'ayant toujours pas résolu le problème je n'ai pas poursuivi leur évolution

reste maintenant a savoir la quelle va aller dans mon xlam menucontextCell
testé sur 200 cellules elle ont toutes un temps très proche sauf la regex
la plus rapide étant la "incrementation par instr" mais étant la moins modifiable

la plus facile(boucle sur split) étant la plus longue, mais de part la structure du code elle est modifiable a volonté

trop de choix tue le choix

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

patricktoulon

XLDnaute Barbatruc

pierrejean

patricktoulon

XLDnaute Barbatruc

laurent950

XLDnaute Barbatruc

patricktoulon

XLDnaute Barbatruc

laurent950

XLDnaute Barbatruc

patricktoulon

XLDnaute Barbatruc