Try this code
Sub Test()
Dim rng As Range, iRow As Long, lr As Long, m As Long
Application.ScreenUpdating = False
With ActiveSheet
.Columns("E:H").ClearContents
lr = .Cells(Rows.Count, 1).End(xlUp).Row + 1
m = 3
For iRow = 4 To lr
If .Cells(iRow, "B").Value <> .Cells(iRow - 1, "B").Value Then
Set rng = .Range("A" & m & ":A" & iRow - 1)
.Cells(iRow - 1, "E").Value = .Cells(iRow - 1, "B").Value
.Cells(iRow - 1, "F").Value = CountUniqueValues(rng)
.Cells(iRow - 1, "G").Formula = "=SUM(" & rng.Offset(, 2).Address(0, 0) & ")"
.Cells(iRow - 1, "H").Formula = "=SUM(" & rng.Offset(, 3).Address(0, 0) & ")"
m = iRow
End If
Next iRow
End With
Application.ScreenUpdating = True
MsgBox "Done", 64
End Sub
Function CountUniqueValues(ByVal rng As Range) As Long
Dim cel As Range, dict As Object
Set dict = CreateObject("Scripting.Dictionary")
For Each cel In rng
If Not dict.Exists(cel.Value) Then dict.Add cel.Value, 1
Next cel
CountUniqueValues = dict.Count
End Function