Sub GroupLigne()
Dim W1 As Worksheet, W2 As Worksheet, Prod As String, SsProd As String, i As Integer, j As Integer
Dim dico, T, TT(1 To 11), TT2
Set dico = CreateObject("Scripting.Dictionary")
Set W1 = Worksheets("Feuil1")
Set W2 = Worksheets("Niveau")
W1.Range("H3:Q11").ClearContents
T = W2.Range("A2:G" & W2.Range("A" & Rows.Count).End(xlUp).Row)
For i = LBound(T, 1) To UBound(T, 1)
If Not dico.exists(T(i, 1)) Then
TT(1) = T(i, 7)
TT(11) = 1
dico(T(i, 1)) = TT
Else
TT2 = dico(T(i, 1))
ind = TT2(11)
TT2(11) = ind + 1
TT2(ind + 1) = T(i, 7)
dico(T(i, 1)) = TT2
End If
Erase TT
Next i
W1.Range("H3").Resize(dico.Count, UBound(TT) - 1) = Application.Transpose(Application.Transpose(dico.items))
End Sub