XL 2013 Suppression des doublons en conservant leurs données

Private Sub Worksheet_Activate()
    Dim Plage, C As Range, D As Range, Col&
    With Application: .ScreenUpdating = False: .Calculation = xlManual: .EnableEvents = False: End With
    Cells.Clear
    With Feuil1
        If .FilterMode Then .ShowAllData
        Set Plage = .Range("A1:A" & .Cells(.Rows.Count, "A").End(xlUp).Row)
        Plage.AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("A1"), Unique:=True
    End With
    For Each C In Range("A2:A" & Cells(Rows.Count, "A").End(xlUp).Row)
        Col = 2
        Plage.AutoFilter Field:=1, Criteria1:=C
        For Each D In Plage.Offset(1).Resize(Plage.Rows.Count - 1).SpecialCells(xlCellTypeVisible)
            Cells(C.Row, Col) = CDate(D.Offset(, 1))
            Col = Col + 1
        Next
    Next
    Plage.AutoFilter
    With Application: .EnableEvents = True: .Calculation = xlAutomatic: .ScreenUpdating = True: End With
End Sub

Private Sub Worksheet_Activate()
Dim d As Object, tablo, i&, x$, a, b(), s, ub%, ubmax%, j%
Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = vbTextCompare 'la casse est ignorée
tablo = Sheets("BDD").[A1].CurrentRegion.Resize(, 2) 'matrice, plus rapide
For i = 1 To UBound(tablo)
    x = tablo(i, 1)
    If Not d.exists(x) Then d(x) = x
    d(x) = d(x) & Chr(1) & tablo(i, 2)
Next
'---restitution---
Application.ScreenUpdating = False
If FilterMode Then ShowAllData 'si la feuille est filtrée
Cells.Delete 'RAZ
If d.Count Then
    a = d.items
    ReDim b(UBound(a), Columns.Count - 1) 'base 0
    For i = 0 To UBound(a)
        s = Split(a(i), Chr(1))
        ub = UBound(s)
        If ub > ubmax Then ubmax = ub
        For j = 0 To UBound(s)
            b(i, j) = s(j)
    Next j, i
    If ubmax + 1 Then [A1].Resize(i, ubmax + 1) = b
    Columns.AutoFit 'ajuste les largeurs
End If
With UsedRange: End With 'actualise les barres de défilement
End Sub

Sub EnLigne()
Dim PresenceTitre As Boolean, der&, t, ref, i&, n&, k&, max&, CellulleRes As Range
   Application.ScreenUpdating = False
   With Sheets("Feuil1")
      PresenceTitre = Not (IsDate(.Range("b1")))
      If .FilterMode Then .ShowAllData
      der = .Cells(.Rows.Count, "a").End(xlUp).Row
      .Range("d1").CurrentRegion.Clear
      .Range("d1").Resize(der, 2) = .Range("a1").Resize(der, 2).Value
      .Range("d1").Resize(der, 2).Sort key1:=.Range("d1"), order1:=xlAscending, Header:=IIf(PresenceTitre, xlYes, xlNo)
      t = .Range("d1").Resize(der, 2)
      .Range("d1").Resize(der).RemoveDuplicates Columns:=1, Header:=IIf(PresenceTitre, xlYes, xlNo)
      der = .Cells(.Rows.Count, "d").End(xlUp).Row
      .Range("e1").EntireColumn.Clear
      ReDim r(1 To der, 1 To 1)
      n = 1: ref = t(1, 1): r(n, 1) = t(1, 2): k = 1: max = 1
      For i = 2 To UBound(t)
         If t(i, 1) = ref Then
            r(n, 1) = r(n, 1) & ";" & t(i, 2)
            k = k + 1
            If k > max Then max = k
         Else
            n = n + 1: ref = t(i, 1): r(n, 1) = t(i, 2): k = 1
         End If
      Next i
      .Range("e1").Resize(UBound(r), UBound(r, 2)) = r
      ReDim f(0 To max - 1)
      For i = 0 To max - 1: f(i) = Array(i + 1, xlDMYFormat): Next
      .Range("e1").Resize(UBound(r)).TextToColumns Destination:=.Range("e1"), DataType:=xlDelimited, Semicolon:=True, FieldInfo:=f
      .Range("d1").Resize(der, max + 1).Interior.Color = RGB(225, 225, 225)
      .Range("d1").Resize(, max + 1).EntireColumn.AutoFit
      .Range("e1").HorizontalAlignment = xlRight
   End With
End Sub

tablo = Sheets("BDD").[A1].CurrentRegion.Resize(, 2).Value2 'matrice, plus rapide

Private Sub Worksheet_Activate()
Dim ncol%, d As Object, tablo, i&, x$, y$, a, b(), s, ub%, ubmax%, j%
ncol = 14 'nombre de colonnes du tableau source
Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = vbTextCompare 'la casse est ignorée
tablo = Sheets("BDD").[A1].CurrentRegion.Resize(, ncol).Value2 'matrice, plus rapide
For i = 1 To UBound(tablo)
    x = tablo(i, 6) 'colonne F
    If Not d.exists(x) Then
        y = ""
        For j = 1 To ncol: y = y & Chr(1) & tablo(i, j): Next j
        d(x) = Mid(y, 2)
    End If
    d(x) = d(x) & Chr(1) & tablo(i, 5) 'dates en colonne E
Next i
'---restitution---
Application.ScreenUpdating = False
If FilterMode Then ShowAllData 'si la feuille est filtrée
Cells.Delete 'RAZ
If d.Count Then
    a = d.items
    ReDim b(UBound(a), Columns.Count - 1) 'base 0
    For i = 0 To UBound(a)
        s = Split(a(i), Chr(1))
        ub = UBound(s)
        If ub > ubmax Then ubmax = ub
        For j = 0 To UBound(s)
            b(i, j) = s(j)
    Next j, i
    If ubmax + 1 Then
        With [A1].Resize(i, ubmax + 1)
            .Value = b
            Union(.Columns(5), .Columns(ncol + 1).Resize(, ubmax + 1 - ncol)).NumberFormat = "dd/mm/yyyy"
        End With
    End If
    Columns.AutoFit 'ajuste les largeurs
End If
With UsedRange: End With 'actualise les barres de défilement
End Sub