title: Sorting items by recent dates VBA
body: <p>I have a database where i should display training list for each employee in a company.
  The training are in the cells (A,41) in my excel worksheets like this : </p>
  
  <p><a href="https://i.stack.imgur.com/xhBaY.png" rel="nofollow noreferrer">enter image description here</a></p>
  
  <p>I wrote a code that helped me to make a new list for the training without duplicates and show only recent date for each training like this: </p>
  
  <p><a href="https://i.stack.imgur.com/ahtDP.png" rel="nofollow noreferrer">enter image description here</a></p>
  
  <p>However when I display the result in a userform I have duplicates : </p>
  
  <p><a href="https://i.stack.imgur.com/Hl7Xy.png" rel="nofollow noreferrer"><img src="https://i.stack.imgur.com/Hl7Xy.png" alt="enter image description here"></a>
  My code is : </p>
  
  <pre><code>Private Sub tri_PE()
  Dim dercol As Long, t, i As Long, j As Long, dico, x, ech As Boolean
  
  With ActiveWorkbook.Worksheets(Personne)
  '   With Sheets("DEBEYER Nicolas")
        'lecture du tableau des formations
        dercol = .Cells(41, .Rows.Columns.Count).End(xlToLeft).Column
        t = Application.Transpose(.Range("41:42").Resize(, dercol).Value2)
  
        'tri de t sur la première colonne (numéro de foemation) sans les en-têtes
        Do
           ech = False
           For i = 2 To UBound(t) - 1
              If t(i + 1, 1) &lt; t(i, 1) Then
                 x = t(i, 1): t(i, 1) = t(i + 1, 1): t(i + 1, 1) = x
                 x = t(i, 2): t(i, 2) = t(i + 1, 2): t(i + 1, 2) = x: ech = True
              End If
           Next i
        Loop Until Not ech
  
        ' conversion des numéros en texte (pour le dico et la listbox)
        ' et les fausses dates (en texte) en vraies dates
        On Error GoTo PasDate
        For i = 2 To UBound(t)
           t(i, 1) = CStr(t(i, 1))
           If TypeName(t(i, 2)) = "String" Then t(i, 2) = 1 * DateSerial(Right(t(i, 2), 4), Mid(t(i, 2), 4, 2), Left(t(i, 2), 2))
        Next i
        On Error Resume Next
  
        'remplissage de dico
        Set dico = CreateObject("scripting.dictionary")
        dico.CompareMode = TextCompare
        For i = 2 To UBound(t)
           If t(i, 1) &lt;&gt; "" Then
              If Not dico.Exists(t(i, 1)) Then
                 dico.Add t(i, 1), t(i, 2)
              Else
                 If t(i, 2) &gt; dico(t(i, 1)) Then dico(t(i, 1)) = t(i, 2)
              End If
           End If
        Next i
  
     'Transfert de dico vers le tableau r pour la liste
     ReDim r(1 To dico.Count, 1 To 2): i = 0
     For Each x In dico.Keys: i = i + 1: r(i, 1) = x: r(i, 2) = dico(x): Next
  
     'remplissage des lignes 48 et 49 de la feuille de chaque personne
     .Range("b48:b49").Resize(, Columns.Count - 1).Clear
     .Range("b48").Resize(1, UBound(r)).NumberFormat = "000"
     .Range("b48").Resize(1, UBound(r)).HorizontalAlignment = xlCenter
     .Range("b49").Resize(1, UBound(r)).NumberFormat = "dd/mm/yyyy"
     .Range("b48").Resize(2, UBound(r)).Borders.LineStyle = xlContinuous
     .Range("b48:b49").Resize(2, UBound(r)) = Application.Transpose(r)
  
     End With
  
     'remplissage de la listbox
     For i = 1 To UBound(r): r(i, 1) = Format(r(i, 1), "000"): r(i, 2) = Format(r(i, 2), "dd/mm/yyyy"): Next
  
     With ListBox1
        .ColumnCount = 2
        .ColumnHeads = False
        .ColumnWidths = .Width * 0.7        '&amp; ";" &amp; .Width * (1 - 0.6 + 0.1)
        .List = r
     End With
     Exit Sub
  
  
  PasDate:
     MsgBox "La valeur de la cellule " &amp; Cells(42, i).Address(0, 0) &amp; " ne peut être convertie en date  -&gt; Echec et Fin.", vbCritical
     ActiveWorkbook.Worksheets(Personne).Cells(42, i).Select
     End
  End Sub
  </code></pre>
  
  <p>How can I delete the duplicates in my listbox ? 
  Thank you </p>