Sub test()
Dim rng As Range, var As Variant
Dim uLevel0 As Variant, x As Long, z As Long, a As Long
Dim oVar As Variant
Dim oRng As Range, rCell As Range
Set rng = Range("A2:D" & Range("A" & Rows.Count).End(xlUp).Row)
var = rng.Value
With Application
uLevel0 = .Unique(.Index(rng, , 3))
ReDim oVar(.CountA(.Index(rng, , 3)) + UBound(uLevel0) * 2, 2)
For x = 1 To UBound(uLevel0)
oVar(z, 0) = uLevel0(x, 1): z = z + 1
For a = 1 To UBound(var)
If var(a, 3) = uLevel0(x, 1) Then
oVar(z, 1) = var(a, 1)
oVar(z, 2) = Format(var(a, 4), "0,0")
z = z + 1
End If
Next a
oVar(z, 2) = Format(.SumIf(.Index(rng, , 3), uLevel0(x, 1), .Index(rng, , 4)), "0,0")
z = z + 1
Next x
Set oRng = Range("G2").Resize(UBound(oVar) + 1, 3)
oRng = oVar
For Each rCell In .Index(oRng, , 1)
If rCell.Value <> vbNullString Then
With rCell.Font
.Color = 10384908
.Bold = True
End With
ElseIf rCell.Offset(, 2) <> vbNullString And rCell.Offset(, 1) = vbNullString Then
With rCell.Offset(, 2).Font
.Bold = True
End With
End If
Next rCell
End With
End Sub