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:
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!
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:
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!
