Recherche dans une BD et tri d'une liste par fréquence

Private Sub Worksheet_Activate()
Dim celdest As Range, sup As Range, t, rest(), n&, i&
Set celdest = [B2] 'la cellule qu'on veut...
Application.ScreenUpdating = False
celdest.Resize(, 2).EntireColumn.Insert 'ajout de 2 colonnes auxiliaires
With Sheets("BD").[A1].CurrentRegion
  celdest(, 0).Resize(.Rows.Count) = .Columns(1).Value 'dates
  celdest.Resize(.Rows.Count) = .Columns(3).Value 'noms
  celdest(, -1).Resize(.Rows.Count) = .Columns(4).Value 'les "NON"
  'remplacement des "NON" puis suppression des lignes
  celdest(, -1).Resize(.Rows.Count).Replace "NON", "#N/A", xlWhole
  On Error Resume Next 's'il n'y a pas de "#N/A"
  Set sup = celdest(, -1).Resize(.Rows.Count).SpecialCells(xlCellTypeConstants, 16)
  Intersect(sup.EntireRow, celdest(, -1).Resize(.Rows.Count, 3)).Delete xlUp
  On Error GoTo 0
  'tri sur les noms puis décroissant sur les dates
  celdest(, 0).Resize(.Rows.Count, 2).Sort celdest, , , celdest(, 0), xlDescending, Header:=xlYes
  t = celdest(, 0).Resize(.Rows.Count, 2) 'matrice, plus rapide
End With
ReDim rest(1 To UBound(t), 1 To 3)
rest(1, 2) = "NOM": rest(1, 3) = "NOMBRE"
n = 1
For i = 2 To UBound(t)
  If t(i, 2) <> "" Then
    If t(i, 2) <> t(i - 1, 2) Then
      n = n + 1
      rest(n, 1) = t(i, 1) 'date
      rest(n, 2) = t(i, 2) 'nom
      rest(n, 3) = 1 'fréquence
    Else
      rest(n, 3) = rest(n, 3) + 1
    End If
  End If
Next
With celdest(, 0).Resize(n, 3)
  .Value = rest
  'tri décroissant sur les nombres puis sur les dates
  .Sort celdest(, 2), xlDescending, , celdest(, 0), xlDescending, Header:=xlYes
End With
If n > 21 Then n = 21
celdest(n + 1).Resize(Rows.Count - n - celdest.Row + 1, 2).Delete xlUp
celdest(, -1).Resize(, 2).EntireColumn.Delete 'en commentaire pour voir
t = Me.UsedRange 'repositionne la barre de défilement verticale
End Sub

Function Fréquents(champ As Range, dt As Range, ColD As Range)
  Set d1 = New Dictionnaire
  Set d2 = New Dictionnaire
  temp = champ
  temp2 = dt.Value2
  temp3 = ColD
  For i = LBound(temp) To UBound(temp)
    c = temp(i, 1)
    If c <> "" And UCase(temp3(i, 1)) <> "NON" Then
       If d1.Existe(c) Then
         d1.affecte c, d1.item(c) + 1
         If temp2(i, 1) > d2.item(c) Then d2.affecte c, temp2(i, 1)
       Else
         d1.ajout c, 1
         d2.ajout c, temp2(i, 1)
       End If
    End If
  Next i
  Dim b()
  ReDim b(1 To d1.count, 1 To 3)
  i = 1
  For Each c In d1.listeCles
    b(i, 1) = c: b(i, 2) = d1.item(c): b(i, 3) = d2.item(c)
    i = i + 1
  Next
  Call Tri(b, 1, d1.count)
  Fréquents = b
End Function

Private Sub Worksheet_Activate()
Dim celdest As Range, sup As Range, t, rest(), n&, i&
Set celdest = [B2] 'la cellule qu'on veut...
Application.ScreenUpdating = False
celdest.Resize(, 2).EntireColumn.Insert 'ajout de 2 colonnes auxiliaires
With Sheets("BD").[A1].CurrentRegion
  celdest(, 0).Resize(.Rows.Count) = .Columns(1).Value 'dates
  celdest.Resize(.Rows.Count) = .Columns(3).Value 'noms
  celdest(, -1).Resize(.Rows.Count) = .Columns(4).Value 'les "NON"
  'remplacement des "NON"
  celdest(, -1).Resize(.Rows.Count).Replace "NON", "#N/A", xlWhole
  'tri pour accélérer
  celdest(, -1).Resize(.Rows.Count, 3).Sort celdest(, -1), xlAscending, Header:=xlYes
  'suppression des lignes des #N/A
  On Error Resume Next 's'il n'y a pas de "#N/A"
  Set sup = celdest(, -1).Resize(.Rows.Count).SpecialCells(xlCellTypeConstants, 16)
  Intersect(sup.EntireRow, celdest(, -1).Resize(.Rows.Count, 3)).Delete xlUp
  On Error GoTo 0
  'tri sur les noms puis décroissant sur les dates
  celdest(, 0).Resize(.Rows.Count, 2).Sort celdest, , , celdest(, 0), xlDescending, Header:=xlYes
  t = celdest(, 0).Resize(.Rows.Count, 2) 'matrice, plus rapide
End With
ReDim rest(1 To UBound(t), 1 To 3)
rest(1, 2) = "NOM": rest(1, 3) = "NOMBRE"
n = 1
For i = 2 To UBound(t)
  If t(i, 2) <> "" Then
    If t(i, 2) <> t(i - 1, 2) Then
      n = n + 1
      rest(n, 1) = t(i, 1) 'date
      rest(n, 2) = t(i, 2) 'nom
      rest(n, 3) = 1 'fréquence
    Else
      rest(n, 3) = rest(n, 3) + 1
    End If
  End If
Next
With celdest(, 0).Resize(n, 3)
  .Value = rest
  'tri décroissant sur les nombres puis sur les dates
  .Sort celdest(, 2), xlDescending, , celdest(, 0), xlDescending, Header:=xlYes
End With
If n > 21 Then n = 21
celdest(n + 1).Resize(Rows.Count - n - celdest.Row + 1, 2).Delete xlUp
celdest(, -1).Resize(, 2).EntireColumn.Delete 'en commentaire pour voir
t = Me.UsedRange 'repositionne la barre de défilement verticale
End Sub

Private Sub Worksheet_Activate()
Dim celdest As Range, x As Variant, i&, t, rest(), n&
Set celdest = [B2] 'la cellule qu'on veut...
Application.ScreenUpdating = False
celdest.Resize(, 2).EntireColumn.Insert 'ajout de 2 colonnes auxiliaires
With Sheets("BD").[A1].CurrentRegion
  celdest(, 0).Resize(.Rows.Count) = .Columns(1).Value 'dates
  celdest.Resize(.Rows.Count) = .Columns(3).Value 'noms
  celdest(, -1).Resize(.Rows.Count) = .Columns(4).Value 'les "NON"
  'remplacement des "NON"
  celdest(, -1).Resize(.Rows.Count).Replace "NON", "zzz", xlWhole
  'tri pour mettre les "zzz" en bas
  celdest(, -1).Resize(.Rows.Count, 3).Sort celdest(, -1), xlAscending, Header:=xlYes
  'nouvelle hauteur du tableau à étudier
  x = Application.Match("zzz", celdest(, -1).Resize(.Rows.Count), 0)
  If IsError(x) Then i = .Rows.Count Else i = x - 1
  'tri sur les noms puis décroissant sur les dates
  celdest(, 0).Resize(i, 2).Sort celdest, , , celdest(, 0), xlDescending, Header:=xlYes
  t = celdest(, 0).Resize(i, 2) 'matrice, plus rapide
End With
ReDim rest(1 To UBound(t), 1 To 3)
rest(1, 2) = "NOM": rest(1, 3) = "NOMBRE"
n = 1
For i = 2 To UBound(t)
  If t(i, 2) <> "" Then
    If t(i, 2) <> t(i - 1, 2) Then
      n = n + 1
      rest(n, 1) = t(i, 1) 'date
      rest(n, 2) = t(i, 2) 'nom
      rest(n, 3) = 1 'fréquence
    Else
      rest(n, 3) = rest(n, 3) + 1
    End If
  End If
Next
With celdest(, 0).Resize(n, 3)
  .Value = rest
  'tri décroissant sur les nombres puis sur les dates
  .Sort celdest(, 2), xlDescending, , celdest(, 0), xlDescending, Header:=xlYes
End With
If n > 21 Then n = 21
celdest(n + 1).Resize(Rows.Count - n - celdest.Row + 1, 2).Delete xlUp
celdest(, -1).Resize(, 2).EntireColumn.Delete 'en commentaire pour voir
t = Me.UsedRange 'repositionne la barre de défilement verticale
End Sub

Function Fréquents(champ As Range, dt As Range, ColD As Range)
  Dim b():  ReDim b(1 To champ.Rows.count, 1 To 3)
  temp = champ
  temp2 = dt.Value2
  temp3 = ColD
  n = 0
  For i = LBound(temp) To UBound(temp)
      c = temp(i, 1)
      If c <> "" And UCase(temp3(i, 1)) <> "NON" Then
      témoin = False
      For j = 1 To n
        If b(j, 1) = c Then p = j: témoin = True
      Next j
      If témoin Then
        b(p, 1) = c: b(p, 2) = b(p, 2) + 1
        If temp2(i, 1) > b(p, 3) Then b(p, 3) = temp2(i, 1)
      Else
         n = n + 1
         b(n, 1) = c: b(n, 2) = 1: b(n, 3) = temp2(i, 1)
      End If
    End If
  Next i
  Call Tri(b, 1, n)
  Fréquents = b
End Function

'-----
  'tri sur les noms puis décroissant sur les dates
  celdest(, 0).Resize(i, 2).Sort celdest, , , celdest(, 0), xlDescending, Header:=xlYes
'-----
  'tri décroissant sur les nombres puis sur les dates
  .Sort celdest(, 2), xlDescending, , celdest(, 0), xlDescending, Header:=xlYes

'-----
  'tri sur les noms puis décroissant sur les dates
  celdest(, 0).Resize(i, 2).Sort celdest, , celdest(, 0), , xlDescending, Header:=xlYes
'-----
  'tri décroissant sur les nombres puis sur les dates
  .Sort celdest(, 2), xlDescending, , celdest(, 0), , xlDescending, Header:=xlYes