Sub part()
Dim k As Long, j As Long, c(), b()   
ActiveSheet.UsedRange.Sort [B1], xlAscending, , , , , , xlNo
    j = Cells(Rows.Count, 1).End(xlUp).Row
    c = Range("B1:B" & j).value: b = Range("N1:N" & j).value
    For k = UBound(c, 1) To 2 Step -1
        If c(k, 1) = c(k - 1, 1) Then
            b(k - 1, 1) = b(k - 1, 1) + b(k, 1): c(k, 1) = Empty
        End If
    Next
    [B1].Resize(UBound(c, 1)).value = c: [N1].Resize(UBound(b, 1)).value = b
    On Error Resume Next
    Range("B1:B" & j).SpecialCells(4).EntireRow.Delete
    On Error GoTo 0
End Sub

Sub Storm_ZCooler() 'http://www.planetaexcel.ru/forum.php?thread_id=45363
Dim Uniq As New Collection, Lastrow As Long, i As Long, j As Long, Arr(), Arr2()
Lastrow = Cells(Rows.Count, 5).End(xlUp).Row
Range(Cells(2, 5), Cells(Lastrow + 1, 6)).Clear
Lastrow = Cells(Rows.Count, 1).End(xlUp).Row
Arr = Range(Cells(2, 1), Cells(Lastrow, 2)).Value
    For i = 1 To UBound(Arr, 1)
        On Error Resume Next
        Uniq.Add Arr(i, 1), CStr(Arr(i, 1))
    Next
    ReDim Arr2(1 To Uniq.Count, 1 To 2)
    For i = 1 To Uniq.Count
        For j = 1 To UBound(Arr, 1)
            If Arr(j, 1) = Uniq(i) Then
                Arr2(i, 1) = Uniq(i)
                Arr2(i, 2) = Arr2(i, 2) + Arr(j, 2)
            End If
        Next
    Next
    Range(Cells(2, 5), Cells(Uniq.Count + 1, 6)) = Arr2
End Sub

n = Range("A:A").Cells.SpecialCells(xlCellTypeConstants).Count

Sub tt()   
Dim LastRow As Long, i As Long   
LastRow = Cells(Rows.Count, 1).End(xlUp).Row   
With CreateObject("scripting.dictionary")   
   For i = 2 To LastRow   
   .Item(Cells(i, 1).Value) = .Item(Cells(i, 1).Value) + 1   
   Cells(i, 1) = Cells(i, 1) & "-" & .Item(Cells(i, 1).Value)   
   Next   
End With   
End Sub