Automatically add multiple original field entries total (that has multiple entries)

Results added to column d

Option Explicit
Sub abc()
 Const shName As String = "sheet1" '<-- Change for you needs
 Dim aArr, i As Long
 
 With Sheets(shName)
    aArr = .Range("a1").CurrentRegion.Value
 End With
 
 With CreateObject("scripting.dictionary")
    .comparemode = 1
    For i = 1 To UBound(aArr, 1)
        If Not .exists(aArr(i, 1)) Then
            .Item(aArr(i, 1)) = aArr(i, 3)
        Else
            .Item(aArr(i, 1)) = .Item(aArr(i, 1)) + aArr(i, 3)
        End If
    Next
    For i = 2 To UBound(aArr, 1)
        Sheets(shName).Cells(i, "d") = .Item(aArr(i, 1))
    Next
 End With
End Sub