XL 2019 Plusieurs lignes avec mêmes donnés

Private Sub Worksheet_Activate()
Dim d As Object, tablo, resu(), i&, x$, n&, nn&
Set d = CreateObject("Scripting.Dictionary")
tablo = Sheets("BDD").[A1].CurrentRegion.Resize(, 3)
ReDim resu(1 To UBound(tablo), 1 To 3)
For i = 2 To UBound(tablo)
    x = tablo(i, 3)
    If x <> "" Then
        If Not d.exists(x) Then
            n = n + 1
            d(x) = n 'mémorise la ligne
            resu(n, 1) = tablo(i, 1) 'date
            resu(n, 3) = "=HYPERLINK(""mailto:" & x & """,""" & x & """)" 'formule
        End If
        nn = d(x) 'récupère la ligne
        resu(nn, 2) = resu(nn, 2) + Val(Replace(tablo(i, 2), ",", ".")) 'montant
    End If
Next
'---restitution---
If FilterMode Then ShowAllData 'si la feuille est filtrée
With [A2] '1ère cellule de destination
    If n Then .Resize(n, 3) = resu
    .Offset(n).Resize(Rows.Count - n - .Row + 1, 3).ClearContents 'RAZ en dessous
End With
End Sub

Sub CumulDonParEmail()
   Dim mondico As Object, c As Range, i As Integer
   Set mondico = CreateObject("Scripting.Dictionary")
   For Each c In Range("C2", [C65000].End(xlUp))
      mondico(c.Value) = mondico(c.Value) + c.Offset(, -1).Value
   Next c
   'restitution sur la même feuille
   [g1].CurrentRegion.ClearContents
   [g1] = "Email": [h1] = "Montant cumulé"
   [g2].Resize(mondico.Count, 1) = Application.Transpose(mondico.keys)
   [h2].Resize(mondico.Count, 1) = Application.Transpose(mondico.items)

   For i = 2 To Range("h" & Rows.Count).End(xlUp).Row
      Cells(i, "h") = Cells(i, "h") * 1   'convertir en chiffre
   Next i
End Sub

let
    Source = Excel.CurrentWorkbook(){[Name="T_Dons"]}[Content],
    ModType = Table.TransformColumnTypes(Source, {{"Date", type date},{"Montant", type number}}, "en-US"),
    Total = Table.Group(ModType, {"Email","Date"}, {{"Montant des dons", each List.Sum([Montant]), type nullable number}})
in
    Total

let
    Source = Excel.CurrentWorkbook(){[Name="T_Dons"]}[Content],
    ModType = Table.TransformColumnTypes(Source, {{"Date", type date},{"Montant", type number}}, "en-US"),
    Total = Table.Group(ModType, {"Email","Date"}, {{"Montant des dons", each List.Sum([Montant]), type nullable number}}),
    Email = Table.ReplaceValue(Total,each [Email],each "'=LIEN_HYPERTEXTE(""" & [Email] & """;""" & [Email] & """)",Replacer.ReplaceText,{"Email"})
in
    Email

Private WithEvents OQT As QueryTable

Private Sub OQT_AfterRefresh(ByVal Success As Boolean)
    Dim Cel As Range
    If Success Then
        For Each Cel In Me.Range("T_Final[Email]")
            Cel.Formula2Local = Replace(Cel.Value, "'=", "=")
        Next Cel
    End If
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If OQT Is Nothing Then Set OQT = Me.Range("T_Final").ListObject.QueryTable
End Sub