Sub SousTotal()
Set d = CreateObject("Scripting.Dictionary")
Set d2 = CreateObject("Scripting.Dictionary")
For Each c In Range("a2", [a65000].End(xlUp))
d(c.Value) = d(c.Value) + c.Offset(, 2).Value
d2(c.Value) = c.Offset(, 1)
Next c
[e2].Resize(d.Count, 1) = Application.Transpose(d.keys)
[f2].Resize(d.Count, 1) = Application.Transpose(d2.items)
[g2].Resize(d.Count, 1) = Application.Transpose(d.items)
End Sub