ajustement des textes dans des cellules fusionnées

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

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