Private Sub Worksheet_Activate()
Dim dest As Range, tablo, d As Object, i&, x$, s, a, b, c()
Set dest = [A2] '1ère cellule de destination, à adapter
tablo = Feuil1.[A1].CurrentRegion.Resize(, 3) 'matrice, plus rapide
Set d = CreateObject("Scripting.Dictionary")
For i = 2 To UBound(tablo)
If IsDate(tablo(i, 2)) Then
x = CStr(tablo(i, 1))
If d.exists(x) Then
s = Split(d(x), Chr(1))
If CDate(tablo(i, 2)) > CDate(s(0)) Then d(x) = tablo(i, 2) & Chr(1) & tablo(i, 3)
Else
d(x) = tablo(i, 2) & Chr(1) & tablo(i, 3)
End If
End If
Next
'---restitution---
If FilterMode Then ShowAllData 'si la feuille est filtrée
If d.Count Then
a = d.keys: b = d.items: ReDim c(UBound(a), 2)
For i = 0 To UBound(a)
c(i, 0) = a(i)
s = Split(b(i), Chr(1))
c(i, 1) = CDate(s(0))
c(i, 2) = s(1)
Next
dest.Resize(d.Count, 3) = c
End If
dest.Offset(d.Count).Resize(Rows.Count - d.Count - dest.Row + 1, 3).Delete xlUp 'RAZ en dessous
With UsedRange: End With 'actualise la barre de défilement verticale
End Sub