ajustement des textes dans des cellules fusionnées

[chaelie2015]

Bonjour forum

Quelqu’un peut m’expliquer comment faire pour ajuster les textes dans des cellules fusionnées

Dans mon exemple ne s’afficher pas complet et quand je mets « aperçu avant l’impression » il s’affiche bien ??????
merci

 

[job75]

Re,

Si l'on veut traiter les cellules dès qu'elles sont modifiées utiliser :

Private Sub Worksheet_Change(ByVal Target As Range)
Set Target = Intersect(Target, [B:B], Me.UsedRange) 'colonne B
If Target Is Nothing Then Exit Sub
Dim marge#
Application.ScreenUpdating = False
Application.DisplayAlerts = False
With TextBox1
  .Visible = False
  For Each Target In Target 'si entrées multiples(copier-coller)
    .AutoSize = False
    .Font.Name = Target.Font.Name
    .Font.Size = Target.Font.Size
    TextBox1 = ""
    .AutoSize = True
    marge = TextBox1.Width - 1 'on conserve une petite marge de 1 point
    .AutoSize = False
    .Width = 5000
    .Value = Target
    .AutoSize = True
    Target.UnMerge
    While Target.MergeArea.Width < TextBox1.Width - marge
      Range(Target, Target.Offset(, 1)).Merge
    Wend
    If Not Intersect(ActiveCell, Target.MergeArea) Is Nothing Then Target.MergeArea.Select
  Next
End With
End Sub

Fichier (3).

A+

 

[job75]

Re,

Pour tester j'ai rempli 1000 cellules en colonne B.

Chez moi sur Win 10 - Excel 2013 la durée d'exécution est de 64 secondes.

Ce n'est finalement pas trop mal car il y a 25 000 fusions...

Fichier joint.

A+

 

[job75]

Re,

Avec ceci la durée d'exécution est de 29 secondes :

Private Sub Worksheet_Change(ByVal Target As Range)
Set Target = Intersect(Target, [B:B], Me.UsedRange) 'colonne B
If Target Is Nothing Then Exit Sub
Dim t, marge#, w#, col%
t = Timer
Application.ScreenUpdating = False
Application.DisplayAlerts = False
With TextBox1
  .Visible = False
  .AutoSize = False
  TextBox1 = ""
  .AutoSize = True
  marge = TextBox1.Width - 1 'on conserve une petite marge de 1 point
  For Each Target In Target 'si entrées multiples(copier-coller)
    .AutoSize = False
    .Font.Name = Target.Font.Name
    .Font.Size = Target.Font.Size
    .Width = 5000
    .Value = Target
    .AutoSize = True
    w = TextBox1.Width - marge
    Target.UnMerge
    col = 1
    While Target.Resize(, col).Width < w: col = col + 1: Wend
    Target.Resize(, col).Merge
    If Not Intersect(ActiveCell, Target.MergeArea) Is Nothing Then Target.MergeArea.Select
  Next
End With
MsgBox "Durée d'exécution " & Format(Timer - t, "0.0 \s"), , "1000 cellules fusionnées"
End Sub

En fait ce qui prend du temps ce sont les manipulations sur la TextBox.

J'ai vérifié que les marges de la TextBox ne dépendent pas de la police, j'ai donc sorti le calcul de marge de la boucle.

Edit : les opérations de fusion elles-mêmes prennent moins d'une seconde !

Fichier (2).

A+