Sub ListeSansDoublons()
Set d = CreateObject("Scripting.Dictionary")
Set d2 = CreateObject("Scripting.Dictionary")
Set d3 = CreateObject("Scripting.Dictionary")
Set d4 = CreateObject("Scripting.Dictionary")
For Each c In Range("b3", [b65000].End(xlUp))
d(c.Value) = d(c.Value) + c.Offset(, 1).Value
d3(c.Value) = d3(c.Value) + c.Offset(, 2).Value
If c.Offset(, 1).Value <> "" Then d2(c.Value) = d2(c.Value) + 1
If c.Offset(, 2).Value <> "" Then d4(c.Value) = d4(c.Value) + 1
Next c
For Each c In d.keys
d(c) = d(c) / d2(c)
If d4(c) > 0 Then d3(c) = d3(c) / d4(c)
Next c
[j3].Resize(d.Count, 1) = Application.Transpose(d.keys)
[k3].Resize(d.Count, 1) = Application.Transpose(d.items)
[l3].Resize(d3.Count, 1) = Application.Transpose(d3.items)
End Sub