Salut Mouncef,
voici, un double-clic en [A1] démarre la macro...
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
'
Dim tData, tExtract()
Dim iIdx%
'
Cancel = True
'
If Not Intersect(Target, Range("A1")) Is Nothing Then
Application.ScreenUpdating = False
'
Range("H:M").ClearContents
Range("H:M").Borders.LineStyle = xlNone
Range("H:M").Interior.Color = RGB(255, 255, 255)
'
iRow = Range("A" & Rows.Count).End(xlUp).Row
Range("A2:F" & iRow).Sort key1:=Range("A2"), order1:=xlAscending, key2:=Range("F2"), order2:=xlDescending, Orientation:=xlTopToBottom
tData = Range("A1:F" & iRow).Value
'
For x = 2 To UBound(tData, 1)
If tData(x, 1) <> tData(x - 1, 1) Then
For y = x To x + 2
iIdx = iIdx + 1
ReDim Preserve tExtract(6, iIdx)
If y = x Then tExtract(0, iIdx - 1) = tData(x, 1)
For Z = 2 To 6
tExtract(Z - 1, iIdx - 1) = tData(y, Z)
Next
Next
End If
Next
Range("H2").Resize(iIdx, 6).Value = WorksheetFunction.Transpose(tExtract)
'
Columns("H:M").AutoFit
For x = 2 To iIdx Step 3
Range("H" & x & ":M" & x + 2).BorderAround LineStyle:=xlContinuous
Range("H" & x & ":M" & x + 2).Interior.Color = IIf(Range("H" & x - 1).Interior.Color = RGB(255, 255, 255), RGB(215, 215, 215), RGB(255, 255, 255))
Next
'
Application.ScreenUpdating = True
End If
'
End Sub
A+