Ceci est une page optimisée pour les mobiles. Cliquez sur ce texte pour afficher la vraie page.

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
Trier par date Trier par votes

patricktoulon

XLDnaute Barbatruc
re
et ca c'est la mienne
sensiblement le principe de @pierrejean mais sans proportionner le text
je sais pas en core ce que ca vaut en terme de ressource utilisée sur un paquet de cellules
je fait juste un replace global a la fin
VB: 
Sub testPat()
    Dim T$, L&
    T = [A1].Text
    L = Int([A1].ColumnWidth)
    T = WrappWithAjustEntireWord3(T, L)
    '[A1]=t
    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 WrappWithAjustEntireWord3(ByVal T$, ByVal L&)
    T = Replace(Replace([A1].Value, vbCrLf, " "), Chr(10), " ")
    Do Until i >= Len(T)
        i = i + L
        If i > Len(T) Then Exit Do
        If Mid(T, i, 1) = " " Then
            Mid(T, i, 1) = "*"
        Else
            i = InStrRev(Mid(T, 1, i), " "): Mid(T, i, 1) = "*"
        End If
    Loop
       WrappWithAjustEntireWord3 = Replace(T, "*", vbCrLf)
End Function
j’essaierais de main avec l’incrémentation par le instr la j'ai mal a la tete
 
Vote positif 0 Vote négatif

Staple1600

XLDnaute Barbatruc
Bonjour le fil

[aparté post-couvre-feu]
Je suis étonné (mais peut-être me trompe-je)
Ce genre de titillements de string, c'est un boulot pour RegExp, non ?
Et sachant que Monsieur Patrick n'est pas maciste pour un sou.
Pourquoi donc ne s'est-il exprimé régulièrement dans son VBE en créant l'objet idoine?

[/aparté post-couvre-feu]
 
Vote positif 0 Vote négatif

Staple1600

XLDnaute Barbatruc
Re

[aparté - spécial laurent950]
Je suis sur (ou me trompe-je) que tu n'es pas un champion en humour à la Staple
Il est pourtant évident que le message#17 est juste un trait d'humour.
Ce que patrick semble avoir perçu d'emblée vu ce qu'on peut lire dans le message#18
[/aparté - spécial laurent950]
 
Vote positif 0 Vote négatif

patricktoulon

XLDnaute Barbatruc
re
bonsoir @eriiiic j'ai vu ta discussion c'est un sujet similaire en effet

c'est ce que je disais tout a l'heure il va falloir en effet ajouter dans une de mes fonctions
  1. l'impossibilité de forcer un nombre de caractères inférieur au len du plus grand mot
  2. garder en effet les saut de ligne originals
si vous avez des idées de méthodes
comme pour le reste je ferais des comparaisons
rapidité
consommation
 
Vote positif 0 Vote négatif

patricktoulon

XLDnaute Barbatruc
re
bon de bon matin comme ca vite fait à la fraiche
et vraiment pour faire plaisir à @StapleMille_six_cent

VB: 
Function justeuntest(ByVal T$, ByVal L&)
    Dim matchs, r
    With CreateObject("VBScript.RegExp"):
        .Global = True: .IgnoreCase = True:
        .Pattern = "([A-z-0-9]{" & L + 1 & "," & L + 20 & "})": Set matchs = .Execute(T)
        If matchs.Count > 0 Then justeuntest = "un mot est trop long dans la chaine": Exit Function

        .Pattern = "(\D{1," & L & "})\s": Set matchs = .Execute(T)
        If matchs.Count > 0 Then
            For i = 0 To matchs.Count - 1: r = r & Trim(matchs(i)) & "-->" & Len(Trim(matchs(i))) & vbCrLf: Next
            
            justeuntest = r
        End If
        
    End With

End Function
Sub test1()
    Dim T$, L&
    T = [A1].Text
    L = Int([A1].ColumnWidth)
   MsgBox "pour A1" & vbCrLf & justeuntest(T, L)
  
    T = [A2].Text
    MsgBox "pour A2" & vbCrLf & justeuntest(T, L)
 
End Sub
 
Vote positif 0 Vote négatif

patricktoulon

XLDnaute Barbatruc
bonjour @pierrejean , @Staple1600 , @mapomme , @zebanx , @laurent950,@sylvanu ,@eriiiic

bon j'ai fait une compil de ce qui fonctionne et (a peu près)
pour commencer fausse joie hier la fonction de @pierrejean sans état d’âme me supprime ce qui est en trop
en effet je démarre avec un mot de 14 caractères et je demande des phrase de 12 ben les 2 premiers caractères envolés je corrige avec une gestion d'erreur Y

alors la version de zebanx va savoir alors là je commande plus rien si un mot trop long, ben sa fonction ne fait pas de détail elle m'agrandi le max donc dans l’exemple qui suit je passe de 12 a 14 puis au fur et a mesure 16/17

ma fois c'est des fonctions qui décident toutes seules

je suis revenu a ma base qui incrémentais le x par le instr et contrôle de la oldposition basique
elle semble fonctionner avec gestion d'erreur si longueur < que un mot dans la chaîne (le test est fait su 2 cellules)

j'ai mis aussi dans le fichier la version regex
bon ben celle ci no comment rien a dire sinon que (un peu lourde lorsqu ’ elle est appliquée sur une plage

maintenant faut voir avec des sauts de lignes existants
comment je vais aborder la chose
des idées???
 

Pièces jointes

  • compil des méthodes pour la fonction wrapp.xlsm
    29.5 KB · Affichages: 12
Dernière édition:
Vote positif 0 Vote négatif

patricktoulon

XLDnaute Barbatruc

sacré laurent va on te changera pas hein
je te sors 3 ou 4 petites fonctions toute mimines et voila fidèle a toi même tu me sort un chalutier

et va y que je te split du len pour trimer l' épicière sans vergogne , pour lui donner le coup de grace dans une boucle finale de coup de rein

mais ça va continuer ubound longtemps comme ça???
 
Vote positif 0 Vote négatif
Identifiez-vous ou inscrivez-vous pour participer.
Menu
Connexion
S'inscrire
Les cookies sont requis pour utiliser ce site. Vous devez les accepter pour continuer à utiliser le site. En savoir plus…