Discussion :

[patricktoulon]

Bonjour a tous
pour un autre sujet Unparia m'a donné une astuce pour gérer le fontweight ou même le fontWidth

j'ai plus ou moins repris l'astuce pour en faire autre chose :un compteur de ligne

en effet c'est un sujet qui est apparu très souvent: comment détecter les sauts de lignes dans une cellules quand il n'y en a pas!!!

mais que la propriété (format cellule/ajuster a la ligne) est activée et donc le texte visuellement sur plusieurs lignes

j'ai donc créé une petite fonction que je viens vous montrer

elle a lair de fonctionner correctement au vues des tests que j'ai fait

cependant je me pose une question au sujet de ce + 9 que l'on trouve dans la fonction on peut aller jusqu'à +7
a quoi est il du ?au fait que le texte dans les cellules a une marge gauche tandis que le label en autosize non ?
ma 2d question c'est aurait il un moyen de simplifier le code bien qu'étant pas très volumineux c'est peu de le dire
voila la fonction

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
 
Function ligne(cel)
   If cel.Text <> "" Then
    Set Obj = ActiveSheet.OLEObjects.Add("Forms.Label.1")
    With Obj:
        .Object.Font.Size = cel.Font.Size:
        e = 1
        Do
         DoEvents
         i = i + 1
            .Object.AutoSize = False
            .Width = 1000:
            .Object.Caption = Mid(cel.Text, 1, i):
            .Object.AutoSize = True:
            a = a + Mid(cel.Text, i, 1)
            If .Width > (cel.Width - 9) * e Then a = a & vbCrLf: e = e + 1
        Loop Until i = Len(cel.Text)
          .Delete
    End With
    ligne = a
End If
End Function

et la sub de test

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
Sub test()
    Dim texte As String, cel As Range
    Set cel = ActiveSheet.[b2]
    texte = cel.Text
    ar = ligne(cel)
    MsgBox ar
End Sub

si vous avez une autre voie a proposer je prends aussi bien entendu
merci pour vos retours et participation d'avance

[Docmarti]

Bonjour Patrick.

Une facon KISS.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
 Sub TestRetourALaLigne()
  Set c = Cells(2, 2)
 
  c.Value = "C'est une triste chose de penser que la nature parle et que le genre humain n'écoute pas." & vbLf & "Victor Hugo"
  c.WrapText = True
 
  MsgBox CalculerNbrLignes(c)
 
 End Sub
 Function CalculerNbrLignes(c)
 
  Set cel2 = Worksheets("Feuil2").Cells(1, 1)
 
  cel2.Parent.Rows("1").Clear
  cel2.ColumnWidth = c.ColumnWidth
 
  c.Copy cel2
 
  cel2.WrapText = c.WrapText
  h = cel2.RowHeight
 
  cel2.WrapText = False
 
  CalculerNbrLignes = h / cel2.RowHeight
 
 End Function

[patricktoulon]

Bonjour Docmarti
j'y avais pensé au rowheight en effet mais attention au formatage de la cellule si sa dimension avais été modifiée avant donc au pire utiliser la cells(rows.count,columns.count) pour le rapport
il y a moins de risque qu'elle ne soit pas d origine
cela dit ma question a été mal formulée j'en suis seul responsable

non seulement je veut le nombre de lignes mais je veux aussi le contenu ligne par ligne

je garde quand même ta façon KISS

a ma façon kissou

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
SSub TestRetourALaLigne()
    Set c = Cells(2, 2)
    c.Value = "C'est une triste chose de penser que la nature parle et que le genre humain n'écoute pas." & vbLf & "Victor Hugo"
    c.WrapText = True
    MsgBox CalculerNbrLignes(c)
End Sub
Function CalculerNbrLignes(c)
    Set cel2 = c.Parent.Cells(Rows.Count, Columns.Count)
    cel2.Clear
    cel2.ColumnWidth = c.ColumnWidth
    h = cel2.RowHeight
     cel2.Value = c.Value
    cel2.WrapText = c.WrapText
    CalculerNbrLignes = cel2.RowHeight / h
    cel2.Clear
End Function

par contre pour l'obtention de la valeur de chaque ligne c'est walouh le calcule donnerait faux
mais ca me donne une autre idée

[patricktoulon]

re
@docmarti je suis parti de ta version kiss
mais je n'arrive pas a mettre au point le passage des saut de ligne reel et chose étonnante avec le même width le texte d'une ligne peut être plus long

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
Sub TestRetourALaLigne()
    Set c = Cells(2, 2)
    c.Value = "C'est une triste chose de penser que la nature parle et que le genre humain n'écoute pas." & vbLf & "Victor Hugo"
    c.WrapText = True
    MsgBox UBound(CalculerNbrLignes(c))
End Sub
Function CalculerNbrLignes(c) As Variant
    ReDim tablo(30)
    tabl = Split(c.Value, " ")
    Set cel2 = Cells(4, 2)    ' 'c.Parent.Cells(Rows.Count, Columns.Count)
    cel2.Clear
    cel2.ColumnWidth = c.ColumnWidth
    cel2.WrapText = c.WrapText:
    h = cel2.RowHeight
    a = 0
    For i = 0 To UBound(tabl)
        If InStr(tabl(i), vbLf) > 0 Then tabl(i) = Replace(tabl(i), vbLf, ""): saut = True
        cel2.Value = cel2.Value & tabl(i) & " "
        If cel2.RowHeight = h Then
            tablo(a) = tablo(a) & tabl(i) & " "
        Else
            a = a + 1: tablo(a) = tabl(i) & " "
            h = cel2.RowHeight
        End If
        If saut = True Then a = a + 1: saut = False
    Next
ReDim Preserve tablo(0 To a)
    cel2.Clear
    cel2.Resize(UBound(tablo), 1) = Application.Transpose(tablo)
    CalculerNbrLignes = tablo
End Function

[Docmarti]

Attention. Le texte suivant

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

 c.Value = "C'est une triste chose de penser que la nature parle et que le genre humain n'écoute pas." & vbLf & "Victor Hugo"

contient un retour de ligne.
Il ne faut pas le supprimer car il fait partie du texte original.

[patricktoulon]

@Nicolas
bien venu dans mon nouveau motif de tourment cérébral
alors le but est de :

1. connaitre le nombre de ligne
2. connaitre la valeur de chaque ligne

une cellule ajustée a la ligne automatiquement par le menu (format cellule --->ajuster a la ligne automatiquement)affiche le texte sur plusieurs ligne ( c'est ce que l'on appelle le (wraptext)
tu constatera que si tu fait une recherche de saut de ligne par chr(10),chr(13),vbcrlf,vblf) tu n'en trouvera pas pourtant il y a bien plusieur lignes visuellement

donc le but avec le label en autosize c'est de l'alimenter jusqu'à quel théoriquement il atteigne la largeur de la cellule parti de la on a une ligne et on continue jusqu' au len(du texte)en mettant un repère a chaque fois que la (limite width * ligne déjà passée) est atteinte
ca fonctionne a peu près correctement

docmarti a apporter une idée en mémorisant le row height de départ et en le comparant au rowheight de l'arrivée en effet le compte est bon
seulement je voudrais avoir la valeur de chaque lignes

j'ai donc mijoté le code dans le post précédant mais c'est pas tout a fait au point
c'est une question que j'ai trouvé de nombreuses fois dans ce même forum et même ailleurs mais aucune vrai solution n'a pu être apporté a ce jour du moins je ne l'ai pas trouvé
alors haut les cœurs

[patricktoulon]

Attention. Le texte suivant

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

 c.Value = "C'est une triste chose de penser que la nature parle et que le genre humain n'écoute pas." & vbLf & "Victor Hugo"

contient un retour de ligne.
Il ne faut pas le supprimer car il fait partie du texte original.

oui docmarti la variable "saut" sert a traiter ce paramètre c'est justement la gestion de ce détail qui est le premier couic !
je pense pas le gérer correctement dans mon model
le 2d detail troublant c'est que un texte dans la cellule ajuster peut prendre une ligne et dans le résultat 2 avec le même columnwidth

[Docmarti]

Patrick, a partir de ton code.

KISS

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
Sub TestRetourALaLigne2()
    Set c = Cells(2, 2)
    c.Value = "                       C'est une triste chose de penser que la nature parle et que le genre humain n'écoute pas." & vbLf & "Victor Hugo"
    c.WrapText = True
    MsgBox UBound(CalculerNbrLignes(c)) + 1
End Sub
Function CalculerNbrLignes(c) As Variant
 
    ReDim tablo(0)
    Set cel2 = Cells(4, 2)
    cel2.Clear
    cel2.ColumnWidth = c.ColumnWidth
    cel2.WrapText = c.WrapText:
     a = 0
    strTxt = Replace(c.Value, vbCrLf, vbLf)
 
    tablVbLf = Split(strTxt, vbLf)
 
    For j = 0 To UBound(tablVbLf)
 
    tabl = Split(tablVbLf(j), " ")
 
    h = cel2.RowHeight
 
    For i = 0 To UBound(tabl)
 
        cel2.Value = cel2.Value & tabl(i) & " "
        If cel2.RowHeight = h Then
            tablo(a) = tablo(a) & tabl(i) & " "
        Else
          a = a + 1:
         ReDim Preserve tablo(a)
            tablo(a) = tabl(i) & " "
            h = cel2.RowHeight
        End If
 
    Next
 
    If j < UBound(tablVbLf) Then
 
      a = a + 1
      ReDim Preserve tablo(a)
      cel2.Value = cel2.Value & vbLf
    End If
 
    Next
 
    Offset = 1
    Columns("C").Clear
    For i = 0 To UBound(tablo)
     cel2.Offset(Offset, 1).Select
     cel2.Offset(Offset, 1) = tablo(i)
     Offset = Offset + 1
    Next
 
    CalculerNbrLignes = tablo
 
End Function

[patricktoulon]

je m'incline j'ai testé dans tout les sens ca match perfect !!!
en même temps j'était vraiment pas loin
peut être que dans le replace initial on pourrait replacer toute les forme de saut de ligne chr(10),chr(13),vbcrlf,vbclf, etc.....

compris:
boucle sur le split par saut de ligne
sous boucle par les espaces
incrementation de a si width ou augmentation de j

dommage un challenge qui n'aura pas duré longtemps

je vais chercher quelque chose de plus compliqué
version finale :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
Sub TestRetourALaLigne2()
    Set c = Cells(2, 2)
    c.Value = "                       C'est une triste chose de penser que la nature parle et que le genre humain n'écoute pas." & vbLf & "Victor Hugo"
    c.WrapText = True
    MsgBox UBound(CalculerNbrLignes(c)) + 1
End Sub
Function CalculerNbrLignes(c) As Variant
 
    ReDim tablo(0)
    Set cel2 = Cells(4, 2)
    cel2.Clear
    cel2.ColumnWidth = c.ColumnWidth
    cel2.WrapText = c.WrapText:
     a = 0
    strTxt = Replace(c.Value, vbCrLf, vbLf)
     tablVbLf = Split(strTxt, vbLf)
     For j = 0 To UBound(tablVbLf)
     tabl = Split(tablVbLf(j), " ")
     h = cel2.RowHeight
 
    For i = 0 To UBound(tabl)
 
        cel2.Value = cel2.Value & tabl(i) & " "
        If cel2.RowHeight = h Then
            tablo(a) = tablo(a) & tabl(i) & " "
        Else
          a = a + 1:
         ReDim Preserve tablo(a)
            tablo(a) = tabl(i) & " "
            h = cel2.RowHeight
        End If
 
    Next
 
    If j < UBound(tablVbLf) Then
 
      a = a + 1
      ReDim Preserve tablo(a)
      cel2.Value = cel2.Value & vbLf
    End If
 
    Next
 
 cel2.Resize(UBound(tablo) + 1, 1) = Application.Transpose(tablo)
    CalculerNbrLignes = tablo
 MsgBox Join(tablo, vbCrLf)
End Function

docmarti
je sais pas si tu t'en rends compte mais tu trouvera aucune version nulpart plus ou moins abracadabranthesque qui fonctionne correctement et tu peut remonter en arrière de quelque années en plus et dieux sais qu'il y a des exemples en masse
Bravo

EDIT:
oulah!!! attention les espace devant la chaine n'est pas anodine si je l'enleve de la chaine de depart ca ne vas pas du tout
peut etre va t il falloir fair un ajout avant traitement
du genre
app.rept(" ",cel.width/cel.font.size)

[mercatog]

Essaies ceci

"Anticonstitutionnellement est un mot très long à écrire :hap: Voilà"

[patricktoulon]

Bonjour Mercatog
oui je viens de faire le test sans les espaces deveant et ca change tout
donc on continu
je pense que je me suis fourvoyé en voulant coller au plus proche en faisant par mot et pour coller au comportement de la cellule

je vais donc modifier mon model avec le label
en bouclant sur les mot et sous boucler sur les caractères
si tout les caractères du mot rentre OK sinon passe a la ligne

puisque boucle sur les mots ca match pas a 100%
boucle sur les caractères ca match pas a 100%
mixer les deux pour coller au plus proche du comportement du wraptext
exemple
une cellule de 110 pixels de width

avec
mercatog pat = 1 ligne

avec
mercatog Patrick = 2 lignes
donc
mercatog
Patrick
le "pat" est décalé en ligne suivante
c'est pour ca que par les caractères c'est pas possible par les mots non plus visiblement
donc il me faut les deux
du moins logiquement par rapport au comportement du wraptext
il faut que je teste le comportement avec un seul mot tres long comme tu dis ca doit différer un peut je pense

[patricktoulon]

je pense avoir trouver un autre moyen
avec 2 autre cellules en autofit
l'une pour tester la largeur du mot complet l'autre pour tester la largeur de ce qui a déjà été pris en compte plus le mot

la première si le mot dépasse la largeur de la cellule original on le coupe donc incrémentation de ligne et alimentation tablo

la 2 d si bon ajoute sinon incrémentation de ligne et alimentation

je dois partir en inter je reviens ce soir pour étudier cela
bon aprem
a+

[patricktoulon]

Bon voila j'ai un résultat mais ce qui me gène c'est la calcul qui semble pas donner un résultat exact a chaque fois selon la dimension de la cellules
maintenant ca gere la phrase ou le mot si il est trop long

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
[Sub TestRetourALaLigne()
    Set c = Cells(2, 2)
    c.Value = "C'est une triste chose de penser que la nature anticonstitutionellement parle et que le genre humain n'écoute pas." & vbCrLf & "Victor Hugo"
    c.WrapText = True
End Sub
Sub testx()
    Dim Cel2, Cel3, I, M, Z, TEXTE, H, mot, mots
    Set cel1 = [b2]
    Set Cel2 = [c1]: Cel2.WrapText = True: Cel2.ColumnWidth = cel1.ColumnWidth: Cel2.ClearContents: H = Cel2.RowHeight
    Set Cel3 = [d2]: ActiveSheet.Columns("D").AutoFit
    phrase = Split(cel1.Value, vbCrLf)
    Z = -1
    Do
        Z = Z + 1
        mots = Split(phrase(Z), " ")
        M = -1
        Do
            M = M + 1
            Cel3.Value = mots(M)
            ActiveSheet.Columns(Cel3.Column).AutoFit
            If Cel3.ColumnWidth > cel1.ColumnWidth Then
                TEXTE = TEXTE & vbCrLf
                nbl = Cel3.ColumnWidth / (Cel3.ColumnWidth / cel1.ColumnWidth)
                For I = 1 To Len(mots(M)) Step nbl + 3: mot = mot & Mid(mots(M), I, nbl + 3) & " ": Next
                TEXTE = TEXTE & Replace(Trim(mot), " ", vbCrLf) & " "
                Cel2.Value = Cel2.Value & mots(M) & " "
                H = Cel2.RowHeight
            Else
                Cel2.Value = Cel2.Value & mots(M) & " "
                TEXTE = TEXTE & mots(M) & " "
                If Cel2.RowHeight > H Then TEXTE = Replace(TEXTE, mots(M), vbCrLf & mots(M)): H = Cel2.RowHeight
            End If
        Loop Until M = UBound(mots)
        Cel2.Value = Cel2.Value & vbCrLf
    Loop Until Z = UBound(phrase)
    MsgBox TEXTE
End Sub

[Docmarti]

J'ai bien l'impression que c'est possible uniquement si la cellule d'origine utilise une police a chasse non proportionnelle et qu'on lui applique en plus EntireColumn.AutoFit.

[patricktoulon]

Bonjour docmarti

tu l'aura compris dans cet exemple on traite non seulement les phrase (plusieurs mot sur la même ligne) mais aussi les mots qui seraient éventuellement trop longs

je sais ce que tu veux dire par police en chasse mais la version que j'ai déposé fonctionne mais c'est le + 3 qui me gène

j'aurais préféré un calcul avec les données des démentions directement

j'ai essayé de travailler en pixel et le résultat est plus probant visiblement

[patricktoulon]

quest ce que ca donne ca chez toi

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
Sub testZ()
ppx = (ActiveWindow.ActivePane.PointsToScreenPixelsX(3) - ActiveWindow.ActivePane.PointsToScreenPixelsX(0) / 3)
     Set Cel2 = [c1]: Cel2.WrapText = True: H = Cel2.RowHeight
    Cel2.Value = "anticonstitutionellement"
   Set Cel3 = [d1]:
   Cel3.Value = Cel2.Value
  ActiveSheet.Columns("D").AutoFit: Cel3.Font.Size = Cel2.Font.Size
  sizec1 = Cel2.Width * ppx
sizec2 = Cel3.Width * ppx
coeff = (sizec2 / sizec1)
MsgBox Mid(Cel2, 1, (Len(Cel2) / coeff))
End Sub

j'ai plutôt l'impression qu'il y a un margin left et right a respecter dans le calcul

[Docmarti]

Chez moi, ca donne le bon resultat mais pas toujours.
Exemple si b2.columnwidth et c1.columnwidth est egal a 8, ca ne donne plus le bon resultat.

[patricktoulon]

oui je sais
je me demande bien quelle règle est appliqué avec ce wraptext

1. nous savons qu'il y a un margin left on le voit bien
2. nous savons aussi qu'un mot trop long est coupé mais étonnamment il n'y a plus ce margin left
3. nous savons qu'il ne coupe pas un mot mais qu'il le met a la ligne si celui ci ajouté au texte existant dépasse la largeur
4. nous savons aussi que ces 3 précédents détails sont traités différemment selon la taille de la cellules

purée on passe a coté de quelque chose la mais quoi?