Sub Макрос1()

Dim k As Long, ins_ As Boolean

Dim stroki As Range, rng As Range, summ
Set stroki = ThisWorkbook.Worksheets("Sheet1").Range("A1", "A11")
 
    For Each rng In stroki
        
        If rng.Value = rng.Offset( 1 ).Value Then
           k = k +  1 
           ins_ = False
           summ = summ + rng.Offset(,  1 ).Value
        ElseIf ins_ = False Then
           ins_ = True
           If InStr( 1 , rng.Offset( 1 ).Value, "итого", vbTextCompare) =  0  Then
                rng.Offset( 1 ).EntireRow.Insert
                stroki.Range(rng.Offset(-k).Row & ":" & rng.Row).Group
           End If
           rng.Offset( 1 ).Value = "итого по " & rng.Value
           rng.Offset( 1 ,  1 ).Value = summ + rng.Offset(,  1 ).Value
           summ =  0 
           k =  0 
        End If
        
    Next
End Sub