Concaténer les cellules et combiner les montants

Bonjour à tous:

Je suis une débutante en VBA et j'ai 2 questions concernant comment concaténer certaines cellules et combiner certains montants. Voici les détails:

Month Group Name Amount Age Sex Rate

avr-16 ABC001 Mary 1 40 F 0.5

avr-16 ABC001 Mary 2 40 F 0.5

avr-16 CDE002 Jack 4 30 M 0.38

avr-16 CDE003 Mark 8 50 M 0.6

avr-16 ABC001 Mary 16 40 F 0.5

avr-16 CDE002 Jack 32 30 M 0.38

Mon objectif:

1. Ajouter une colonne à la fin pour concaténer les cellules Name&Âge&Group, selon cette concaténation on peut distinguer les doublons, par exemple Mary&40&ABC001);

2. Calculer la somme de Amount selon la colonne de concaténation (par exemple pour Mary: 1+2+16=19 ), mais la somme 19 apparaît seulement sur la première ligne de chaque concaténation différente et le reste lignes en doublon devient 0. Le reste de champs ne changent pas, voici le résultat que je voulais:

Month Group Name Amount Age Sex Rate

avr-16 ABC001 Mary 19 40 F 0.5

avr-16 ABC001 Mary 0 40 F 0.5

avr-16 CDE002 Jack 4 30 M 0.38

avr-16 CDE003 Mark 8 50 M 0.6

avr-16 ABC001 Mary 0 40 F 0.5

avr-16 CDE002 Jack 32 30 M 0.38

3. J'aimerais effacer le contenu dans la colonne ajoutée pour la concaténation.

Merci beaucoup!

Bonsoir,

Une proposition avec formule.

Bonjour,

Merci de votre proposition. Mais je voudrais réaliser les 3 objectifs dans une même procédure en VBA.

Merci beaucoup!

Re,

Quel intérêt de le faire en VBA si une fonction y suffit ?

Bonjour,

et un tcd ne convient pas ?

P.

Bonjour,

C'est un de mes projets annuels de réaliser ces 3 objectifs par VBA et dans le même temps j'aimerais bien apprendre plus sur VBA.

Merci beaucoup!

Bonsoir à tous,

Vois ceci :

Tes données en feuil1 à partir de A1

Option Explicit
Sub test()
Dim a, w(), i As Long, txt As String
    a = Sheets("feuil1").Range("a1").CurrentRegion.Value
    With CreateObject("Scripting.Dictionary")
        .Comparemode = 1
        For i = 2 To UBound(a, 1)
            txt = Join$(Array(a(i, 2), a(i, 3), a(i, 5)), Chr(2))
            If Not .exists(txt) Then
                ReDim w(1 To 2)
                w(1) = True
            Else
                w = .Item(txt)
            End If
            w(2) = w(2) + a(i, 4)
            .Item(txt) = w
        Next
        For i = 2 To UBound(a, 1)
            txt = Join$(Array(a(i, 2), a(i, 3), a(i, 5)), Chr(2))
            If .exists(txt) Then
                w = .Item(txt)
                If w(1) = True Then
                    a(i, 4) = w(2)
                    w(1) = False
                Else
                    a(i, 4) = 0
                End If
            End If
            .Item(txt) = w
        Next
        Sheets("feuil1").Range("a1").CurrentRegion.Resize(, 7).Value = a
    End With
End Sub

klin89

Re linedolc,

Plus simple que la version précédente

Option Explicit
Sub test()
Dim a, w(), i As Long, txt As String
    a = Sheets("feuil1").Range("a1").CurrentRegion.Value
    With CreateObject("Scripting.Dictionary")
        .Comparemode = 1
        For i = 2 To UBound(a, 1)
            txt = Join$(Array(a(i, 2), a(i, 3), a(i, 5)), Chr(2))
            If Not .exists(txt) Then
                ReDim w(1 To 2)
                w(1) = i
            Else
                w = .Item(txt)
            End If
            w(2) = w(2) + a(i, 4)
            .Item(txt) = w
        Next
        For i = 2 To UBound(a, 1)
            txt = Join$(Array(a(i, 2), a(i, 3), a(i, 5)), Chr(2))
            If .Item(txt)(1) = i Then
                a(i, 4) = .Item(txt)(2)
            Else
                a(i, 4) = 0
            End If
        Next
        Sheets("feuil1").Range("a1").CurrentRegion.Resize(, 7).Value = a
    End With
End Sub

klin89

Bonjour Klin89,

Merci beaucoup de votre aide. Ça fonctionne super bien. ^_^

Bonjour Klin89,

Est-ce que c'est possible d'ajouter les explications pour chaque ligne de la code? Je suis en trains d'apprendre le VBA et j'ai eu le misère de comprendre les fonctions que tu utilises.

Merci beaucoup!