Bonjour à tous,

J'ai récemment eu le problème classique de l'ajustement automatique des cellules fusionnées. Problème auquel j'ai trouvé une solution en fouillant sur le net. Toutefois, lorsque j'entre le code, l'ajustement automatique ne se fait plus pour les autres cellules de la ligne.

Exemple: Le texte de la cellule fusionnée fait 2 lignes, l'ajustement automatique s'effectue sans problème.

Sauf que si dans la case suivante, non-fusionnée, j'entre un texte de 3 lignes, l'ajustement reste bloqué à 2 lignes.

Voici mon code:

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
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo Err_Worksheet_Change
Dim Cel As Range
Dim Cel_L As Range
Dim Larg As Double
Dim Plage_T As String
 
 
If Intersect(Target, Columns("A")) Is Nothing Then GoTo Sort_Worksheet_Change
 
Application.ScreenUpdating = False
Application.EnableEvents = False
Plage_T = Intersect(Target, Columns("A")).Address(0, 0)
For Each Cel In Range(Plage_T)
    Larg = 0
    For Each Cel_L In Cel.MergeArea
        Larg = Larg + Cel_L.ColumnWidth
    Next Cel_L
    Columns("Q").ColumnWidth = Larg
    Cells(Cel.Row, "Q") = Cel.Value
    Range("Q" & Cel.Row).WrapText = True
    Rows(Cel.Row).AutoFit
    Rows(Cel.Row).RowHeight = Rows(Cel.Row).RowHeight
    Columns("Q").Delete
Next Cel
 
Sort_Worksheet_Change:
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    Exit Sub
Err_Worksheet_Change:
    MsgBox Err.Description, vbOKOnly + vbCritical, "ERREUR EXCEL n°" & Err.Number
    Resume Sort_Worksheet_Change
End Sub
Quelqu'un aurait un solution?

Merci!