Private Sub toto(r, c, d, Ref)
Dim i&, h#
Application.ScreenUpdating = 0
i = Range(Cells(r, d), Cells(Rows.Count, d).End(xlUp).Offset(1)).Rows.Count
With Range(Cells(r, d - 1), Cells(Rows.Count, d - 1).End(xlUp).Offset(1)).Rows: i = IIf(i < .Count, .Count, i)
.Resize(i, 3).UnMerge
With Application: .EnableEvents = 0: .Calculation = -4135: End With
For i = 1 To i
With .Cells(i)
If Not IsEmpty(.Value) Then .Cut Destination:=.Offset(, 1)
End With
Next
With Application: .Calculation = -4105: .EnableEvents = 1: End With
With .Resize(i, 3): .Interior.Color = RGB(255, 255, 204): .Rows.EntireRow.AutoFit: End With
End With
With Range(Cells(r, c), Cells(Rows.Count, c).End(xlUp)).Rows: i = IIf(i < .Count, .Count, i) - 1: End With
For i = 0 To i
With Cells(r, d).Offset(i)
Select Case Cells(r, c).Offset(i).Value
Case Ref(0): With .Resize(1, 2): .Interior.Color = RGB(192, 240, 64): .Merge: End With
Case Ref(1): h = .RowHeight: With .Offset(, -1).Resize(1, 2): .Interior.Color = RGB(240, 201, 224): .Merge: .RowHeight = h: End With
End Select
End With
Next
Application.ScreenUpdating = 1
End Sub
Private Sub Worksheet_BeforeDoubleClick(ByVal Cible As Range, Contremander As Boolean)
Dim c&, d&, r&
r = 2 'Première ligne de données
c = Columns("J").Column 'Colonne de clef
d = Columns("F").Column 'Colonne à traiter
If Cible.Row = r + (r > 1) And Cible.Column = c Or Cible.Column = d Then toto r, c, d, Array("RCV", "SNT"): Contremander = True
End Sub