Option Explicit

Sub CreateSubtotals()
    Dim lr As Long, llastr As Long
    
    Application.Calculation = -4135
    Application.ScreenUpdating = 0
    llastr = Cells(Rows.Count, 3).End(xlUp).Row
    Union(Cells(llastr + 1, 4), Cells(llastr + 1, 10)).FormulaR1C1 = "=SUM(" & Cells(llastr, 1).MergeArea.Address(1, 0, xlR1C1) & ")"
    For lr = llastr To 3 Step -1
        If Cells(lr, 1).MergeCells = True Then
            If Cells(lr, 1).MergeArea.Cells(1, 1).Address = Cells(lr, 1).Address Then
                Rows(lr).Insert
                Union(Cells(lr, 4), Cells(lr, 10)).FormulaR1C1 = "=SUM(" & Cells(lr - 1, 1).MergeArea.Address(1, 0, xlR1C1) & ")"
            End If
        End If
    Next lr
    Application.ScreenUpdating = 1
    Application.Calculation = -4105
End Sub