ajustement des textes dans des cellules fusionnées

Option Explicit
Sub Ajuster()
    Dim c As Range
    For Each c In Columns(2).SpecialCells(xlCellTypeConstants)
        If Len(c) > 85 Then
            With c
                .RowHeight = 37
                .HorizontalAlignment = xlLeft
                .VerticalAlignment = xlTop
                .WrapText = True
            End With
        End If
    Next
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If ActiveCell.Column <> 2 Then Exit Sub 'colonne B
Application.ScreenUpdating = False
Application.DisplayAlerts = False
With TextBox1
  .Visible = False
  .AutoSize = False
  .Font.Name = ActiveCell.Font.Name
  .Font.Size = ActiveCell.Font.Size
  .Width = 5000
  .Value = ActiveCell
  .AutoSize = True
End With
ActiveCell.UnMerge
While ActiveCell.MergeArea.Width < TextBox1.Width
  Range(ActiveCell, ActiveCell.Offset(, 1)).Merge
Wend
ActiveCell.MergeArea.Select
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If ActiveCell.Column <> 2 Then Exit Sub 'colonne B
Dim marge#
Application.ScreenUpdating = False
Application.DisplayAlerts = False
With TextBox1
  .Visible = False
  .AutoSize = False
  .Font.Name = ActiveCell.Font.Name
  .Font.Size = ActiveCell.Font.Size
  TextBox1 = ""
  .AutoSize = True
  marge = TextBox1.Width - 1 'on conserve une petite marge de 1 point
  .AutoSize = False
  .Width = 5000
  .Value = ActiveCell
  .AutoSize = True
End With
ActiveCell.UnMerge
While ActiveCell.MergeArea.Width < TextBox1.Width - marge
  Range(ActiveCell, ActiveCell.Offset(, 1)).Merge
Wend
ActiveCell.MergeArea.Select
End Sub
Fichier (2).

A+