option
![]()
Sub ertert() Dim x, y(), i&, j&, k&, n&, s$ x = Range("A2:B" & Cells(Rows.Count, 1).End(xlUp).Row).Value ReDim y(1 To UBound(x), 1 To 2) On Error Resume Next With New Collection For i = 1 To UBound(x) s = Trim$(x(i, 1)) If Len(s) Then If IsEmpty(.Item(s)) Then k = k + 1: y(k, 1) = s: y(k, 2) = x(i, 2) .Add k, s Else n = .Item(s): y(n, 2) = y(n, 2) + x(i, 2) End If End If Next i End With If k > 1 Then [e2:f2].Resize(k).Value = y End Sub
Bookmarks