(VBA) Créer TOP5 des entités les plus répétées

Sub top()

'Volé sur site de Jacques Boigontier : http://boisgontierjacques.free.fr/pages_site/Dictionnaire.htm

Dim D As Object 'déclare la variable D (Dictionnaire)
Dim CEL As Range 'déclare la variable CEL (CELlule)
Dim PL As Range 'déclare la variable PL (PLage)

Set D = CreateObject("Scripting.Dictionary") 'définit le dictionnaire D
For Each CEL In Range("A2:A" & Range("A65536").End(xlUp).Row) 'boucle sur toutes les cellules CEL de la plage nommée "Mes_Objets"
    D(CEL.Value) = D(CEL.Value) + 1 'alimente le dictionnaire D
Next CEL 'prochaine cellule de la boucle
Range("D2").Resize(D.Count, 1) = Application.Transpose(D.keys) 'récupère les noms
Range("E2").Resize(D.Count, 1) = Application.Transpose(D.items) 'récupère le nombre d'occurrence
Set PL = Range("D2").CurrentRegion 'définit la plage PL
PL.Sort Key1:=Range("E2"), Order1:=xlDescending, Header:=xlNo 'tri la plage PL
Range(Cells(7, 4), Cells(Application.Rows.Count, 5)).Clear 'supprime les lignes en trop
End Sub

Set PL = PL.Offset(0, 1).Resize(, PL.Columns.Count - 1) 'redéfinit la plage PL (sans la colonne C)

Sub Pm()
  Dim L As Long
  Columns("D:E").Delete
  [Tb].AdvancedFilter Action:=2, CopyToRange:=[D1], Unique:=1
  [D1] = [A1]
  L = Range("D6500").End(xlUp).Row
  Range("E2:E" & L).FormulaLocal = "=NB.SI(A$2:A$37;D2)"
  Range("D2:E" & L).Sort [E2], 2
  Range("E2:E" & L) = Range("E2:E" & L).Value
End Sub

Private Sub CommandButton1_Click()
Top5
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, [A:A]) Is Nothing Then Top5
End Sub

Sub Top5()
Dim t, d As Object, i&, x, a, b, c()
t = Range("A2", Range("A" & Rows.Count).End(xlUp)(3)) 'au moins 2 éléments
Set d = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(t)
  x = t(i, 1)
  If x <> "" Then d(x) = d(x) + 1
Next
If d.Count Then
  '---transposition (au cas où il y a plus de 65536 éléments)---
  a = d.keys: b = d.items
  ReDim c(UBound(a), 1)
  For i = 0 To UBound(a)
    c(i, 0) = a(i): c(i, 1) = b(i)
  Next
  '---restitution et classement---
  Application.ScreenUpdating = False
  [D2].Resize(d.Count, 2) = c
  [D:E].Sort [E1], xlDescending, Header:=xlYes 'tri
End If
Range("D" & IIf(d.Count < 5, d.Count + 2, 7) & ":E" & Rows.Count).ClearContents
End Sub

Private Sub CommandButton1_Click()
Top5
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, [A:A]) Is Nothing Then Top5
End Sub

Sub Top5()
Dim t, d As Object, i&, x, a, b
t = Range("A2", Range("A" & Rows.Count).End(xlUp)(3)) 'au moins 2 éléments
Set d = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(t)
  x = t(i, 1)
  If x <> "" Then d(x) = d(x) + 1
Next
If d.Count Then
  '---tri VBA---
  a = d.keys: b = d.items
  Call tri(a, b, 0, UBound(a))
  '---restitution---
  For i = 0 To IIf(UBound(a) < 4, UBound(a), 4)
    [D2].Offset(i) = a(i): [E2].Offset(i) = b(i)
  Next
End If
If d.Count < 5 Then Range("D" & d.Count + 2 & ":E6").ClearContents
End Sub

Sub tri(a, b, gauc, droi)         ' Quick sort
Dim ref, g, d, temp
ref = b((gauc + droi) \ 2)
g = gauc: d = droi
Do
    Do While b(g) > ref: g = g + 1: Loop
    Do While ref > b(d): d = d - 1: Loop
    If g <= d Then
      temp = a(g): a(g) = a(d): a(d) = temp
      temp = b(g): b(g) = b(d): b(d) = temp
      g = g + 1: d = d - 1
    End If
Loop While g <= d
If g < droi Then Call tri(a, b, g, droi)
If gauc < d Then Call tri(a, b, gauc, d)
End Sub