Bonsoir à tous,
essaie ceci :
Sub test()
Dim a, e, s, i As Long, ii as byte, n As Long, dico As Object
Application.ScreenUpdating = False
Set dico = CreateObject("Scripting.Dictionary")
dico.CompareMode = 1
With Sheets(1)
a = .Cells(1).CurrentRegion
For i = 2 To UBound(a, 1)
If Not dico.exists(a(i, 1)) Then
Set dico(a(i, 1)) = CreateObject("Scripting.Dictionary")
End If
If Not dico(a(i, 1)).exists(a(i, 2)) Then
ReDim w(1 To 8): w(1) = a(i, 1): w(2) = a(i, 2)
Else
w = dico(a(i, 1))(a(i, 2))
End If
For ii = 3 To UBound(a, 2)
If Not IsEmpty(a(i, ii)) Then
w(ii) = a(i, ii)
End If
Next
dico(a(i, 1))(a(i, 2)) = w
Next
End With
With Sheets.Add
n = 2
.Cells(1).Resize(, UBound(a, 2)) = Application.Index(a, 1, 0)
For Each e In dico
For Each s In dico(e)
.Cells(n, 1).Resize(, UBound(dico(e)(s))) = dico(e)(s)
n = n + 1
Next
Next
With .Cells(1).CurrentRegion
.Font.Name = "Calibri"
.Font.Size = 10
.Rows(1).BorderAround Weight:=2
.Rows(1).Interior.ColorIndex = 43
.VerticalAlignment = xlCenter
.BorderAround Weight:=2
.Borders(xlInsideVertical).Weight = 2
.Columns.AutoFit
End With
End With
Set dico = Nothing
Application.ScreenUpdating = True
End Sub
klin89