Sub MergeAndSum()
On Error Resume Next
Dim rng As Range
Application.DisplayAlerts = False
For Each rng In Range("A1", Range("A10000").End(3))
For i = 1 To 10
If rng.Offset(i, 0).Value = rng.Value Then rng.Offset(0, 1).Value = rng.Offset(0, 1).Value + rng.Offset(i, 1).Value
Next
Next
For Each rng In Range("A1", Range("A10000").End(3))
If rng.Value = rng.Offset(1, 0).Value Then rng.Offset(0, 1).Resize(2, 1).Merge
If rng.Value = rng.Offset(-1, 0).Value Then rng.Offset(-1, 1).Resize(2, 1).Merge
Next
Application.DisplayAlerts = True
Set rng = Nothing
End Sub