Columns and unique IDs

Try this:-
Results start "Y1" (for top 10)

Sub MG19Dec34
Dim Rng As Range, Dn As Range, n As Long
Dim Ac As Long, Lg As Long, K As Variant
Set Rng = Range("B3").Resize(10)
With CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare
For Each Dn In Rng
For Ac = 0 To 21 Step 3
    If Not .Exists(Dn.Offset(, Ac).Value) Then
        .Add Dn.Offset(, Ac).Value, Dn.Offset(, Ac + 1).Value
    Else
        .Item(Dn.Offset(, Ac).Value) = .Item(Dn.Offset(, Ac).Value) + Dn.Offset(, Ac + 1).Value
    End If
Next Ac
Next
ReDim ray(1 To 10, 1 To 2)
For n = 1 To 10
    Lg = Application.Large(.items, n)
    For Each K In .keys
        If .Item(K) = Lg Then ray(n, 1) = K: ray(n, 2) = Lg
    Next K
Next n

Range("Y1").Resize(10, 2) = ray
End With

End Sub

Regards Mick