Sub www() 'http://www.sql.ru/forum/actualthread.aspx?tid=960144
    Dim i%, j&, a, k&, n&
    a = Worksheets(1).Range("a7").CurrentRegion
    Worksheets(1).Range("h7").CurrentRegion.ClearContents
    With CreateObject("Scripting.Dictionary")
        For i = 1 To UBound(a)
            If .exists(a(i, 1)) Then
            n = .Item(a(i, 1))
                For j = 2 To UBound(a, 2)
                    a(n, j) = a(n, j) + a(i, j)
                Next
            Else
                k = k + 1: .Item(a(i, 1)) = k
                For j = 1 To UBound(a, 2)
                    a(k, j) = a(i, j)
                Next
            End If
        Next
    End With
    [h7].Resize(k, 4) = a
End Sub