Sub iSumma()
Dim i As Long
Dim iLastRow As Long
Dim n As Integer
 iLastRow = Cells(Rows.Count, "B").End(xlUp).Row
 Range("D2:D" & iLastRow).ClearContents
  For i = 2 To iLastRow
      Cells(i, "D") = 0
      n = 0
    If Cells(i + n + 1, "B") = Cells(i, "B") Then
      Do
         Cells(i, "D") = Cells(i, "D") + Cells(i + n, "F")
         n = n + 1
      Loop While Cells(i, "B") = Cells(i + n, "B")
         i = i + n - 1
    Else
       Cells(i, "D") = Cells(i, "F")
    End If
  Next
End Sub