Sub iSummaMergeCells()
Dim i As Long
Dim iLastRow As Long
Dim n As Integer
'выключаем некоторые параметры для увеличения скорости обработки файла
    With Application
      .ScreenUpdating = False             'отключение обновление экрана
      .Calculation = xlCalculationManual  'отключение пересчёт формул вручную
      .EnableEvents = False               'отключение событий
      .DisplayAlerts = False              'отключение предупреждающих сообщений
    End With
 iLastRow = Cells(Rows.Count, 1).End(xlUp).Row
  For i = 3 To iLastRow
    If Cells(i, "B").MergeCells Then
      n = Cells(i, "B").MergeArea.Count
      Cells(i, "B") = WorksheetFunction.Sum(Range(Cells(i, "A"), Cells(i + n - 1, "A")))
      i = i + n - 1
    Else
      Cells(i, "B") = Cells(i, "A")
    End If
  Next
    With Application
      .ScreenUpdating = True
      .Calculation = xlCalculationAutomatic
      .EnableEvents = True
      .DisplayAlerts = True
    End With
End Sub