Sub svod()
    Application.ScreenUpdating = False
    Set tbl = [b2].CurrentRegion
    With CreateObject("Scripting.Dictionary")
        For i = 2 To tbl.Rows.Count
            For j = 1 To tbl.Columns.Count - 1
                If tbl(1, j) = "Имя" Then
                    If .Exists(Trim(tbl(i, j))) Then
                        .Item(Trim(tbl(i, j))) = .Item(Trim(tbl(i, j))) + tbl(i, j + 1)
                    Else
                        .Add Trim(tbl(i, j)), tbl(i, j + 1)
                    End If
                End If
        Next j, i
        [h3].CurrentRegion.Offset(2).Clear
        [h3].Resize(.Count) = Application.Transpose(.keys)
        [i3].Resize(.Count) = Application.Transpose(.items)
        Set res = [h3].Resize(.Count, 2)
        With ActiveSheet.Sort
            .SortFields.Clear
            .SortFields.Add Key:=res.Columns(2), _
                SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
            .SetRange res
            .Apply
        End With
    End With
    Application.ScreenUpdating = True
End Sub