fusionner des lignes ayant un intitulé identique

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