XL 2019 Plusieurs lignes avec mêmes donnés

[Flochavignaud]

Bonjour, je suis président d'une association nous avons un partenaire qui nous envoie un fichiers avec les donateurs de l'année 2023.
1 ligne = 1 don, mais un donateur peux faire plusieurs dons de même valeur le même jour, je souhaiterai regrouper tous les dons de la même date et du même utilisateur sur un seul et même ligne afin de pouvoir l'importé dans notre CRM et généré les reçu fiscaux.
Le tableau se présente sous cette forme :
Colone A = Date du don, Colone B = Montant du don, Colone C = email
Je ne peux malheureusement pas vous mettre le fichier car il contient des donnés perso des donateurs.
Je vous joint un fichiers reconstituer type afin d'avoir une idée.
Merci pour votre aide.

 

[job75]

Bonjour Flochavignaud, bienvenue sur XLD,

Vous pouvez utiliser le Dictionary pour :

- lister dans les keys les emails sans doublons

- lister dans les items les sommes correspondantes.

Nombreux exemples sur le forum.

A+

 

[Flochavignaud]

Bonjour Job75, merci pour votre réponse.
J'ai trouvez des éléments avec Dictionary sur le forum, mais j'avoue que je ne comprend pas trop.
Pouvez vous m'aider ?
Merci

 

[p56]

Bonjour à tous,
Pour une autre demande, j'ai écrit un code très similaire.
Voici une proposition, mais attention : j'ai remplacé les points de la colonne B par des virgules (mon excel est en Fr) via un simple Ctrl+H avant le traitement =>

P.

 

[Flochavignaud]

Bonjour c'est super ça fonctionne !

Merci beaucoup

Bonne journée

 

[job75]

Avec le Dictionary c'est assez simple :

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

La macro se déclenche automatiquement quand on active la feuille "Grouper".

On notera l'utilisation de la fonction LIEN_HYPERTEXTE.

Bonjour p56.

 

[cp4]

Bonsoir @Flochavignaud , @job75 , @p56

@Flochavignaud : D'après ce que j'ai compris, voici ma participation

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

 

[Cousinhub]

Bonsoir,
Assez simple également avec Power Query
Ne nécessite pas de macro, un clic droit dans le tableau de restitution, "Actualiser" pour mettre à jour
Le code :

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

Le fichier
Bonne soirée

 

[job75]

Bonjour le forum,

Je constate que les emails restitués par p56 post #4 et Cousinhub post #8 ne sont pas cliquables.

A+

 

[Cousinhub]

Bonjour Job
Il ne semble pas que le demandeur ait "besoin" de cliquer sur le lien?
Il souhaite juste importer ces liens, afin de :

.... pouvoir l'importé dans notre CRM et généré les reçu fiscaux...

Bonne journée

 

[job75]

Et moi au post #6 les liens que je créais ne fonctionnaient pas.

Car j'avais oublié "mailto:", je viens de corriger la formule.

 

[job75]

Bonjour Job
Il ne semble pas que le demandeur ait "besoin" de cliquer sur le lien?

Les liens du tableau source étant cliquables il me paraît évident qu'ils doivent l'être dans le résultat.

 

[Cousinhub]

Ouais.....
Bravo

 

[job75]

@Cousinhub que donnerait l'entrée de la formule LIEN_HYPERTEXT avec PQ ?

 

[Cousinhub]

Re-,
Il est possible d'intégrer cette formule directement dans une requête, mais précédée d'une apostrophe
Puis au chargement, utilisation d'un code lors de la mise à jour de la requête pour supprimer l'apostrophe et valider cette formule
D'après un code de mon ami regretté Hasco
Le code M modifié :

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

Et dans le code de la feuille :

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

Le fichier exemple
Bonne journée