try
Sub ertert() Dim i&, j&, Lr&, sm# Lr = Cells(Rows.Count, 1).End(xlUp).Row With Application .ScreenUpdating = False: .DisplayAlerts = False For i = 3 To Lr sm = Cells(i, 7): j = i Do While Cells(i, 1) = Cells(i + 1, 1) sm = sm + Cells(i + 1, 7) i = i + 1: If i > Lr Then Exit Do Loop If i > j Then Cells(j, 1).Resize(i - j + 1).Merge Cells(j, 7).Resize(i - j + 1).Merge Cells(j, 7).Value = sm End If Next i .ScreenUpdating = True: .DisplayAlerts = True End With End Sub
Bookmarks