Microsoft 365 Gestion des doublons

Private Sub Worksheet_Activate()
Dim colmax%, tablo, d As Object, i&, numero, a, b, s, ub%, n&, c$(), j%, dat, col%
colmax = 10000 'nombre maximum de colonnes du tableau des résultats, adaptable
With Sheets("Doublons")
    With .Range("A1", .UsedRange)
        tablo = .Resize(, 31) 'matrice, plus rapide
    End With
End With
ReDim resu(1 To UBound(tablo), 1 To colmax)
Set d = CreateObject("Scripting.Dictionary")
For i = 6 To UBound(tablo)
    numero = tablo(i, 7)
    If numero <> "" Then d(numero) = d(numero) & tablo(i, 31) 'concaténation
Next i
If d.Count = 0 Then Exit Sub 'sécurité
a = d.keys: b = d.items
For i = 0 To UBound(a)
    s = Split(b(i), "-") 'tiret devant les dates
    ub = UBound(s)
    If ub > -1 Then
        n = n + 1
        ReDim c(ub)
        For j = 0 To UBound(s)
            dat = Replace(Left(Trim(s(j)), 8), ".", "/")
            If IsDate(dat) Then c(j) = Format(CDate(dat), "yy/mm/dd") & Mid(Trim(s(j)), 9) 'permet le tri par dates
        Next j
        tri c, s, 0, ub
        resu(n, 1) = a(i)
        col = 1
        For j = ub To 1 Step -1
            If Replace(Replace(s(j), " ", ""), ".", "/") <> Replace(Replace(s(j - 1), " ", ""), ".", "/") Then 'ne tient pas compte des doublons
                col = col + 1
                resu(n, col) = s(j)
            End If
        Next j
        If Trim(s(0)) <> "" Then resu(n, col + 1) = s(0)
    End If
Next i
'---restitution---
If FilterMode Then ShowAllData 'si la feuille est filtrée
With [A2] '1ère cellule de restitution, à adapter
    If n Then .Resize(n, colmax) = resu
    .Offset(n).Resize(.Parent.Rows.Count - n - .Row + 1, colmax).ClearContents 'RAZ au dessous
End With
Columns.AutoFit 'ajustement largeur
With UsedRange: End With 'actualise les barres de défilement
End Sub

Sub tri(a, b, gauc, droi) ' Quick sort
Dim ref, g, d, temp
ref = a((gauc + droi) \ 2)
g = gauc: d = droi
Do
    Do While a(g) < ref: g = g + 1: Loop
    Do While ref < a(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

Sub test()
    Dim newval$, i&, Firstindex&, texte$
    newval = ""
    For i = 6 To Cells(Rows.Count, "G").End(xlUp).Row
        If Cells(i, "G") <> newval Then
            Firstindex = i
            newval = Cells(i, "G")
            texte = ""
        Else
            If Cells(i, "AE") <> "" Then
                Cells(Firstindex, "AE") = Cells(Firstindex, "AE") & " - " & Cells(i, "AE"): Cells(i, "AE") = ""
                'on enleve les doublons(texte dans le resultat en first cellule de chaque valeur
                'en gros on suprime les chaines qui se repete mot pour mots
                t = Split(Cells(Firstindex, "AE"), "-")
                For x = 0 To UBound(t)
                    If Not Trim(t(x)) = "" And Not texte Like "*" & t(x) & "*" Then texte = texte & "-" & t(x)
                Next
                If Left(texte, 1) = "-" Then texte = Mid(texte, 2)
                Cells(Firstindex, "AE") = texte
            End If
        End If
    Next i
End Sub