Sub Otbor()
       Dim a(), oDict As Object, i As Long, temp As String
          
       a = Range("d2:e" & Range("e" & Rows.Count).End(xlUp).Row).Value

       Set oDict = CreateObject("Scripting.Dictionary")

       For i = 1 To UBound(a)
           temp = UCase(Trim(a(i, 2)))
           If Not oDict.Exists(temp) Then
               oDict.Add temp, CStr(a(i, 1))
           Else
               oDict.Item(temp) = CStr(--oDict.Item(temp) + a(i, 1))
           End If
       Next

       With ThisWorkbook.Worksheets(1)
           .Range("i2").Resize(oDict.Count) = Application.Transpose(oDict.keys)
           .Range("j2").Resize(oDict.Count) = Application.Transpose(oDict.items)
       End With

End Sub