Public Sub prctest()
Dim i&, D As Object, T As Variant, Msg$
Set D = CreateObject("Scripting.Dictionary")
With Sheets("BDD")
For i = 2 To .Cells(Rows.Count, 17).End(xlUp).Row
If .Cells(i, 17).Value > 0 And .Cells(i, 18).Value <> "" Then
D(.Cells(i, 17).Value) = .Cells(i, 18).Value
Next i
End With
T = D.Keys
Call prctri(T, LBound(T), UBound(T))
ReDim Preserve T(1 To 6)
For i = 1 To 6
'T(i) = Valeur en colonne Q
'D(T(i)) = Lettre en colonne R
Msg = Msg & T(i) & vbTab & vbTab & D(T(i)) & vbLf
Next i
MsgBox Msg, 64, "Compte rendu"
End Sub