Sub toto() 'La bibliothèque Microsoft Scripting Runtime (scrrun.dll) doit être référencée.
Dim i&, j%, k%, TmpS$, TmpD(), DT(), SD As Scripting.Dictionary, wf As WorksheetFunction
Set wf = Application.WorksheetFunction
Set SD = New Dictionary
DT = Sheets(1).Range("DT").Value 'Plage de données.
k = UBound(DT, 2)
ReDim TmpD(k)
For i = 1 To UBound(DT, 1)
For j = 1 To 2: TmpS = TmpS & CStr(DT(i, j)) & "#": Next 'Clef de sélection : les deux premiers champs.
If Len(TmpS) >= j Then
If SD.Exists(TmpS) Then
TmpD = SD(TmpS)
TmpD(k) = TmpD(k) + 1
SD(TmpS) = TmpD
Else
For j = 1 To k: TmpD(j - 1) = DT(i, j): Next
TmpD(k) = 1&
SD(TmpS) = TmpD
End If
End If
TmpS = Space(0)
Next
Erase DT, TmpD
With Sheets(2).Range("ST") 'Première cellule de la plage de résultats.
.Value = Space(0)
.Resize(.Parent.Cells(.Parent.Rows.Count, .Column).End(xlUp).Row, k + 1).ClearContents
If SD.Count Then .Resize(SD.Count, k + 1).Value = wf.Transpose(wf.Transpose(SD.Items))
End With
Set wf = Nothing
Set SD = Nothing
End Sub