découper texte selon largeur cellule

antiphot

XLDnaute Occasionnel
Bonjour à toutes et à tous

Mon problème est le suivant: dans la cellule A1 par exemple j'ai une phrase de longueur variable. Si le texte dépasse la largeur de la colonne A je souhaite découper la phrase avec trois points de suspension à la fin, puis ajouter un commentaire avec la totalité de la phrase

Pour info je ne veux pas de retour à la ligne, la hauteur de la ligne A1 devant rester fixe.

J'ai essayé de faire une correspondance entre le nombre de caractères et la largeur de la colonne mais sans grand succès.

Si quelqu'un a une idée ?

Cordialement

Ci-joint mon code actuel (sans l'ajout du commentaire)

Sub ContenuSelonLargeur()
Dim c As Range
Range("A1:A10").Select
For Each c In Selection
X = Len(c.Text)
Y = c.ColumnWidth
If Y < X Then
Range("A1").Value = Left(Range("A1"), (X - Y)) & "..."
End If
Next
End Sub
 

gilbert_RGI

XLDnaute Barbatruc
Re : découper texte selon largeur cellule

Bonjour à toutes et à tous

Mon problème est le suivant: dans la cellule A1 par exemple j'ai une phrase de longueur variable. Si le texte dépasse la largeur de la colonne A je souhaite découper la phrase avec trois points de suspension à la fin, puis ajouter un commentaire avec la totalité de la phrase

Pour info je ne veux pas de retour à la ligne, la hauteur de la ligne A1 devant rester fixe.

J'ai essayé de faire une correspondance entre le nombre de caractères et la largeur de la colonne mais sans grand succès.

Si quelqu'un a une idée ?

Cordialement

Ci-joint mon code actuel (sans l'ajout du commentaire)

Sub ContenuSelonLargeur()
Dim c As Range
Range("A1:A10").Select
For Each c In Selection
X = Len(c.Text)
Y = c.ColumnWidth
If Y < X Then
Range("A1").Value = Left(Range("A1"), (X - Y)) & "..."
End If
Next
End Sub

Bonjour

ne pas confondre le nombre de caractères avec le nombre de points de la largeur de colonne
sachant que chaque caractère est différent en largeur d'un autre il est difficile voire impossible de faire comme ceci
ex: M et I sont # en largeur

toutefois si vous voulez obtenir un résultat avec un nombre de caractères pré-défini voici ce qui pourrait vous aider

Code:
Sub ContenuSelonLargeur()
    Dim c As Range
    Range("A1:A10").Select
    For Each c In Selection
    X = Len(c.Text)
    If X > 7 Then
      c.Value = Left(c.Value, 6) & "..."
    End If
    Next
End Sub

Salutations

Gilbert_RGI
 

youky(BJ)

XLDnaute Barbatruc
Re : découper texte selon largeur cellule

Bonjour le fil,
je viens de fignoler la macro, j'envoie tout de même
Utilise le nombre de caractères ne pas modifier la taille de police prévu (10).
Code:
Sub ContenuSelonLargeur()
Dim c As Range
y = [A1].ColumnWidth
For Each c In [A1:A10]
X = Len(c.Text)
If y < X Then
Range(c.Address).Value = Left(Range(c.Address), Int(y)) & "..."
End If
Next
End Sub
 

Catrice

XLDnaute Barbatruc
Re : découper texte selon largeur cellule

Bonjour,

Ci-joint un exemple pour débuter.
Reste plus qu'à gérer les césures ...

Code:
Sub ContenuSelonLargeur()
For Each X In Range("A1:A10")
    If X <> "" And X.ColumnWidth < Len(X.Text) Then
        X.AddComment Right(X.Text, Len(X.Text) - X.ColumnWidth)
        X.Value = Left(X, X.ColumnWidth) & "..."
    End If
Next
End Sub

Edit : Je crois que la largeur de colonne est donnée en nombre de caracteres de la police par défaut.
Ceci donne de résultat différents :

Sub Test()
MsgBox Selection.ColumnWidth 'Largeur en caracteres
MsgBox Selection.EntireColumn.Width 'Largeur en points
End Sub
 

Pièces jointes

  • Classeur1.xls
    24.5 KB · Affichages: 104
  • Classeur1.xls
    24.5 KB · Affichages: 108
  • Classeur1.xls
    24.5 KB · Affichages: 114
Dernière édition:

Modeste

XLDnaute Barbatruc
Re : découper texte selon largeur cellule

Bonjour antiphot, le forum,

Avec les 2 modifications (en rouge) dans ton code, ça fonctionne chez moi:
Code:
Sub ContenuSelonLargeur()
Dim c As Range
Range("A1:A10").Select
For Each c In Selection
X = Len(c.Text)
Y = c.ColumnWidth
     If Y < X Then
        [COLOR="red"][B]c.AddComment (c.Value)[/B][/COLOR]
        Range("A1").Value = Left(Range("A1"), (X - Y)) & "..."
     End If
Next [B][COLOR="Red"]c[/COLOR][/B]
End Sub

Modeste

OUPS: Salut Catrice, youky(BJ), Gilbert_RGI ... suis un peu en retard
 
Dernière édition:

Catrice

XLDnaute Barbatruc
Re : découper texte selon largeur cellule

Re,

Dans Range("A1").Value = Left(Range("A1"), (X - Y)) & "..."

X-Y ne renvoie pas l'effet escompté.
On veut maximum la largeur de colonne donc Left de la largeur de colonne ...
Il se trouve que les "..." rentrent dans la cellule ;)
Voir mon code ...
 
Dernière édition:

job75

XLDnaute Barbatruc
Re : découper texte selon largeur cellule

Bonjour antiphot, le fil,

J'arrive après la bataille, désolé.

Cette macro utilise Columns.AutoFit dans un document auxiliaire :

Code:
Sub ContenuSelonLargeur()
Dim ws As Worksheet, largeur As Single, c As Range, i As Integer
Application.ScreenUpdating = False
On Error Resume Next 'au cas où un commentaire existerait
Set ws = ActiveSheet
largeur = [A1].ColumnWidth
Workbooks.Add 'nouveau document
For Each c In ws.[A1:A10]
  [A1] = ""
  For i = Len(c) To 1 Step -1
    [A1].ColumnWidth = largeur
    [A1] = Left(c.Text, i) & IIf(i = Len(c.Text), "", "...")
    [A1].Columns.AutoFit 'ajustement automatique
    If [A1].ColumnWidth <= largeur Then Exit For
  Next
  If i < Len(c.Text) Then
    c.AddComment
    c.Comment.Text c.Text
  End If
  c = [A1]
Next
ActiveWorkbook.Close False
End Sub

A+
 

Pièces jointes

  • Découper texte.xls
    30.5 KB · Affichages: 93
Dernière édition:

job75

XLDnaute Barbatruc
Re : découper texte selon largeur cellule

Re, salut et merci Catrice :)

Une amélioration qui permet de réajuster comme on veut (augmentation ou diminution) la largeur de la colonne, tout en conservant toujours le texte d'origine.

Il y avait un petit piège, les 3 points pouvant être 3 caractères ou être liés en un seul caractère (code 133) :

Code:
Sub ContenuSelonLargeur()
Dim ws As Worksheet, largeur As Single, c As Range, i As Integer
Application.ScreenUpdating = False
On Error Resume Next
Set ws = ActiveSheet
largeur = [A1].ColumnWidth
Workbooks.Add 'nouveau document
For Each c In ws.[A1:A10]
  [A1] = ""
 [COLOR="Red"] If c = Left(c.Comment.Text, Len(c) - 3) & "..." _
    Or c = Left(c.Comment.Text, Len(c) - 1) & Chr(133) Then c = c.Comment.Text
  c.Comment.Delete[/COLOR]
  For i = Len(c) To 1 Step -1
    [A1].ColumnWidth = largeur
    [A1] = Left(c.Text, i) & IIf(i = Len(c.Text), "", Chr(133)) 'Chr(133): 3 points liés
    [A1].Columns.AutoFit 'ajustement automatique
    If [A1].ColumnWidth <= largeur Then Exit For
  Next
  If i < Len(c.Text) Then
    c.AddComment
    c.Comment.Text c.Text
  End If
  c = [A1]
Next
ActiveWorkbook.Close False
End Sub

A+
 

Pièces jointes

  • Découper texte(1).xls
    32 KB · Affichages: 93
Dernière édition:

antiphot

XLDnaute Occasionnel
Re : découper texte selon largeur cellule

Bonjour à tous

Je reviens juste sur le fil pour une adaptation de la Macro de Job75.
J'ai pensé que cela sera pas mal d'inclure cette procédure dans une macro événementielle de la feuille. Le hic c'est que du coup je n'arrive pas à effacer ou supprimer les cellules qui ont été traitées par la macro. !
 

job75

XLDnaute Barbatruc
Re : découper texte selon largeur cellule

Bonsoir antiphot, le fil, le forum,

J'ai ajouté dans le code de la feuille 2 macros évènementielles.

La macro principale a été un peu modifiée.

Noter que la variable plage est déclarée Public ce qui la mémorise.

J'ai supprimée la variable largeur qui peut être plus nuisible qu'utile.

Edit : Encore une modif sur les 1ers tests, prendre ce fichier.

A+
 

Pièces jointes

  • Découper texte(2).xls
    39 KB · Affichages: 95
Dernière édition:

Discussions similaires

Statistiques des forums

Discussions
311 720
Messages
2 081 909
Membres
101 836
dernier inscrit
karmon