Option Explicit

Sub UniqSummUniversal()    'вариант без Transpose - для больших объёмов
'Выделить диапазон, где в первом столбце - неуникальные, в последнем - суммы
    Dim a(), b(), oDict As Object, i&, ii&, temp$, x&
    Dim ind&
    'Dim tm: tm = Timer
    a = Selection.Value
    ReDim b( 1  To UBound(a,  1 ),  1  To  3 )
    ind = UBound(a,  2 )
    Set oDict = CreateObject("Scripting.Dictionary")
    oDict.CompareMode =  1 
    For i =  1  To UBound(a)
        If Not IsEmpty(a(i, ind)) Then
            If IsNumeric(a(i, ind)) Then
                temp = Trim(a(i,  1 ))
                If Not oDict.Exists(temp) Then
                    ii = ii +  1 
                    b(ii,  1 ) = temp: b(ii,  2 ) = --a(i, ind): b(ii,  3 ) =  1 
                    oDict.Add temp, CStr(ii)
                Else
                    x = oDict.Item(temp)
                    b(x,  2 ) = b(x,  2 ) + --a(i, ind)
                    b(x,  3 ) = b(x,  3 ) +  1 
                End If
            End If
        End If
    Next

    If ii >  0  Then
        With Workbooks.Add.Worksheets( 1 )
            .Columns( 1 ).NumberFormat = "@"
            .Range("A1:C1").Resize(ii) = b
        End With
    Else
        MsgBox "Выделите корректные данные!", vbCritical
    End If
    
    'Debug.Print Timer - tm
    End Sub