Re : Ajustement automatique de la hauteur...
bonjour le forum,
J'ai reussi a denicher un code super pratique qui oermet d'agir automatiquement sur la hauteur des lignes.
Le probléme c'est qu'il ne réajuste que les cellules comme chaine de caratctére (texte) alors que moi je qu'il le fasse sur des valeurs numérique.
Si vous pouvez m'aidera l'adapter pour des valeurs numérique je serais trés reconnaissant;
Voici le code :
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo Err_Worksheet_Change
'Gestion des erreurs rendue nécessaire par blocage action Excel
'Déclaration variables ============================
Dim Cel As Range
Dim Cel_L As Range
Dim Larg As Double
Dim Plage_T As String
'MEI ===============================================
'Validité ------------------------------------------
If Intersect(Target, Columns("B")) Is Nothing Then GoTo Sort_Worksheet_Change
'Si les cellules modifiées n'appartiennent pas à B, on sort
'Blocage actions Excel ------------------------------
Application.ScreenUpdating = False
'Rafraîchissement écran
Application.EnableEvents = False
'Action évènements
'Définition plage ------------------------------------
Plage_T = Intersect(Target, Columns("B")).Address(0, 0)
'On définit la plage de travail comme étant l'adresse relative des cellules
'modifiées qui appartiennent à la colonne B
'Programme ============================================
For Each Cel In Range(Plage_T)
'pour chaque cellule de la plage de travail
Larg = 0
For Each Cel_L In Cel.MergeArea
'Pour chaque cellule fusionnée de cel
Larg = Larg + Cel_L.ColumnWidth
'ajouter la largeur de la colonne à Larg
Next Cel_L
'cellule suivante
Columns("Q").ColumnWidth = Larg
'Largeur de Q = largeur des cellules fusionnées
Cells(Cel.Row, "Q") = Cel.Value
'Cellule Q = valeur de la cellule en cours
Range("Q" & Cel.Row).WrapText = True
'retour à la ligne automatique pour la cellule Q
Rows(Cel.Row).AutoFit
'Ajustement automatique de la ligne de la cellule en cours
Rows(Cel.Row).RowHeight = Rows(Cel.Row).RowHeight
'fixe la hauteur de la ligne à la hauteur ajustée automatiquement
Columns("Q").Delete
'supprimer la colonne Q
Next Cel
'cellule suivante
Sort_Worksheet_Change: 'Sortie unique ==============================
Application.EnableEvents = True
Application.ScreenUpdating = True
'Remise en route des Actions Excel
Exit Sub
Err_Worksheet_Change: 'Gestion des erreurs ========================
MsgBox Err.Description, vbOKOnly + vbCritical, "ERREUR EXCEL n°" & Err.Number
Resume Sort_Worksheet_Change
End Sub
Merciiiiiii