Sub SumsAll() Dim Cnt, Cur, t, i As Integer Dim St(100) As String Dim Sm(100) As Double Dim Fnd As Boolean Dim Strn As String For t = 1 To 100 St(t) = "": Sm(t) = 0 Next t Cnt = 0: Cur = 0: Fnd = False rng = ActiveWindow.RangeSelection.Address For Each rn In Range(rng).Cells If Len(rn) > 1 And Val(rn) = 0 Then If Cnt > 0 Then Fnd = False For t = 1 To Cnt If UCase(St(t)) = UCase(rn) Then Cur = t: Fnd = True: GoTo ex Next t End If 'Cnt>0 ex: If Fnd = False Then Cnt = Cnt + 1 St(Cnt) = rn Cur = Cnt End If Else Sm(Cur) = Sm(Cur) + rn End If Next rn Strn = "" For t = 1 To Cnt Strn = Strn + Mid(St(t), 1, 3) + "=" + CStr(Sm(t)) If t < Cnt Then Strn = Strn + "; " Next t Application.StatusBar = Strn End Sub