Option Base 1
Sub Сумма()
    Dim arr As Variant, i&, s$, d&
    With [B5].CurrentRegion
        With Intersect(.Offset(1), .Cells)
            arr = .Value
            With CreateObject("Scripting.Dictionary")
                For i = 1 To UBound(arr)
                    s = CStr(arr(i, 1))
                    d = arr(i, 3) - arr(i, 4)
                    arr(i, 5) = 0
                    If .Exists(s) Then
                        arr(.Item(s), 5) = arr(.Item(s), 5) + d
                        arr(i, 5) = 0
                    Else
                        arr(i, 5) = d
                        .Item(s) = i
                    End If
                Next i
            End With
            .Value = arr
        End With
    End With
End Sub

=ЕСЛИ(СЧЁТЕСЛИ($B$5:B5;B6);"";СУММЕСЛИ($B$6:$B$14;B6;$D$6:$D$14)-СУММЕСЛИ($B$6:$B$14;B6;$E$6:$E$14))

Private Sub Worksheet_Change(ByVal Target As Range)
   If Target.Count > 1 Then Exit Sub
   PS = Columns("B:E").Find("*", [E1], SearchDirection:=xlPrevious).Row + 1
   If Not Application.Intersect(Range("E6:E" & PS), Target) Is Nothing Then
   Сумма
   End If
End Sub

Sub Сум()
  Dim i&, sm&, ns&
  sm = 0: ns = 6
  For i = 6 To Columns("B:E").Find("*", [E1], SearchDirection:=xlPrevious).Row
      If Cells(i, "B") = Cells(i + 1, "B") Then
         sm = sm + Cells(i, "D") - Cells(i, "E")
      Else
         sm = sm + Cells(i, "D") - Cells(i, "E")
         Cells(ns, "F") = sm
         ns = i + 1: sm = 0
      End If
  Next
End Sub