Sub récap()
Set dico = CreateObject("Scripting.Dictionary")
For Each c In Range([B2], [B65000].End(xlUp))
If c.Value <> "" Then
If Not dico.Exists(c.Value) And c.Value <> "" Then _
dico.Add c.Value, c.Value
End If
Next c
[B24].Resize(dico.Count, 1) = Application.Transpose(dico.items)
lig = [a65000].End(3).Row + 6 'soit 6 lignes aprés la derniere
a = dico.items
For k = 0 To dico.Count - 1
Z = [B22:B2].Find(a(k), , , , 1, 2).Row
Cells(lig, 6) = Cells(Z, 6)
lig = lig + 1
Next
End Sub