Sub ОЛЕЖИЩЕ()
Dim x, y(), i As Long, j As Long, k As Byte, n As Long
Dim rng As Range: Application.ScreenUpdating = False

Set rng = Range("D7:H" & Cells(Rows.Count,  4 ).End(xlUp).Row)
x = rng.Value
ReDim y( 1  To UBound(x,  1 ),  1  To  5 )

With CreateObject("Scripting.Dictionary")
    .CompareMode =  1 
    For i =  1  To UBound(x,  1 )
        If Not .Exists(x(i,  1 )) Then
            j = j +  1 : .Item(x(i,  1 )) = j
            For k =  1  To  5 : y(j, k) = x(i, k): Next k
        Else
            n = .Item(x(i,  1 ))
            y(n,  5 ) = y(n,  5 ) + x(i,  5 )
        End If
    Next
End With

rng.Value = y: Application.ScreenUpdating = True
End Sub