Trier les doublons en colonne 1 en additionnant cells B et C

Le 04/05/2017 à 09:59

Bonjour, je cherche à faire une macro qui me permet de trier les doublons en colonne A en gardant et additionnant les point en colonne B et C, j'ai pu détecter les doublant dans la colonne A, et garder que la dernière valeur de cellule en double sur la colonne B, je n'arrive pas a mettre la somme des cellules en fonction de doublons, sur la colonne B et C

Voilà mon code

Merci d'avance

Sub Report_Profil()

'supprime les doublons et additionne les point pour les doublons

Set mondico = CreateObject("Scripting.Dictionary") 'on instancie le dictionnaire

Dim tablo As Variant 'variable de type tableau qui contiendra les valeur de la plage de cellule a chaque tour de boucle

With Sheets(2)

tablo = .Range("A2:D" & Sheets(2).Range("A" & Rows.Count).End(xlUp).Row)

For i = 1 To UBound(tablo) 'on boucle sur tout le tablo

If Not mondico.Exists(tablo(i, 1)) Then 'si l'element du tablo n'existe pas

mondico.Add (tablo(i, 1)), tablo(i, 2) ', tablo(i, 3), tablo(i, 4) 'on le met dans le dico les noms en cle et les points en item

Else

'Cas ou existe déjà on change llanote a l'item deja present representant ce que contient (tablo(i,1)dans le dico

mondico(tablo(i, 1)) = tablo(i, 2) 'moi je veux additionner les cellules ou j'ai des doublans sur la colonnes B et la meme

'chose avec la colonne B qui n'est pas encore Faite

End If ' fin de condition sur l'existance de l'element

Next i 'fin de boucle tablo

' dans la feuille on efface completement la plage tester uniquement la plage testée

.Range("A2:D" & Sheets(2).Range("A" & Rows.Count).End(xlUp).Row).Clear

'on resize la plage a1 par le nombre de ligne du dico et sur 1 colonne on y colle les noms(colonne 1)

.[A2].Resize(mondico.Count, 1) = Application.Transpose(mondico.Keys)

'on resize la plage b1 par le nombre de ligne du dico et sur 1 colonne on y colle les points(colonne 2)

.[B2].Resize(mondico.Count, 1) = Application.Transpose(mondico.Items)

'on resize la plage C1 par le nombre de ligne du dico et sur 1 colonne on y colle les points(colonne 3)

.[C2].Resize(mondico.Count, 1) = Application.Transpose(mondico.Items)

End With

Set mondico = Nothing

End Sub

Le 04/05/2017 à 10:08

Bonjour,

Tu devrais envisager l'utilisation d'un tableau croisé dynamique (TCD).

Tu pourrais peut-être te passer de VBA.

Pour plus d'informations, joint un fichier à ta demande.

Cdlt.

Le 04/05/2017 à 10:33

Bonjour,

Merci pour votre réponse

non je ne peux pas faire un tableau croisé dynamique, mon manager voulais une macro pour automatiser les traitement, en faite y'as plusieurs taches, et pour le moment je travail sur le traitement des cellules en doublant

31par-profil.xlsm (48.60 Ko)
Le 05/05/2017 à 08:58

Bonjour Rouritta, Bonjour Jean-Eric,

Une adaptation.

Les clés du dictionnaire sont uniques, donc pas besoin de vérifier leur existence:

Sub Report_Profil()
'supprime les doublons et additionne les point pour les doublons
    Set mondico = CreateObject("Scripting.Dictionary")    'on instancie le dictionnaire
    Dim tablo As Variant    'variable de type tableau qui contiendra les valeur de la plage de cellule de chaque sheets a chaque tour de boucle
    With Sheets(2)
        tablo = .Range("A2:D" & Sheets(2).Range("A" & Rows.Count).End(xlUp).Row)
        For i = 1 To UBound(tablo)    'on boucle sur tout le tablo
            mondico(tablo(i, 1)) = mondico(tablo(i, 1)) + tablo(i, 2) + tablo(i, 3)
        Next i    'fin de boucle tablo
        ' dans la feuille on efface completement la plage tester uniquement la plage testée
        .Range("A2:D" & Sheets(2).Range("A" & Rows.Count).End(xlUp).Row).Clear
        'on resize la plage a1 par le nombre de ligne du dico et sur 1 colonne on y colle les noms(colonne 1)
        .[A2].Resize(mondico.Count, 1) = Application.Transpose(mondico.Keys)
        'on resize la plage b1 par le nombre de ligne du dico et sur 1 colonne on y colle les points(colonne 2)
        .[B2].Resize(mondico.Count, 1) = Application.Transpose(mondico.Items)
        'traduction:
        'cellule(X,Y).resize(nombre de ligne dans le dico,1 colonne)=.........
    End With
    Set mondico = Nothing
End Sub

Cordialement

Le 05/05/2017 à 09:26

Bonjour,

Merci, j'ai déja testé cette solution mais moi je veux qu'il me fais la somme des cellules de colonnes B, Somme de cellules de colonne C et somme de cellule de colonne D, pour le moment j'ai le code qui me fait la vérification suivant deux colonnes, me calcule la somme de mes colonne sauf qu'il fusionne deux cellules lors de l'affichage,

une autre chose que je n'arrive pas à la faire c'est faire la division de colonne B / D

voilà mon code que j'essaye de l'adapter

Sub Report_Projet()

' Ressource Par Projet & Maison

Dim q(), s(), r() ', t()

ReDim q(1 To 100), s(1 To 100), r(1 To 100)

Set d = CreateObject("scripting.dictionary")

i = 2

With Sheets("Ressources Net")

While .Cells(i, 1) <> ""

f = .Cells(i, 1) & " " & .Cells(i, 4)

If d.exists(f) Then j = d.Item(f) Else k = k + 1: d.Add f, k: j = k

q(j) = q(j) + .Cells(i, 2)

s(j) = s(j) + .Cells(i, 3)

r(j) = r(j) + .Cells(i, 4)

't(j) = q.Cells(j, 5) & "/" & r.Cells(j, 7)

i = i + 1

Wend

ReDim Preserve q(1 To k)

ReDim Preserve s(1 To k)

ReDim Preserve r(1 To k)

End With

With Sheets("Ressources Projets")

.Range("A2").Resize(d.Count, 1) = Application.Transpose(d.Keys)

.Range("B2").Resize(d.Count, 1) = Application.Transpose(q)

.Range("C2").Resize(d.Count, 1) = Application.Transpose(s)

.Range("D2").Resize(d.Count, 1) = Application.Transpose(r)

'.Range("E2").Resize(d.Count, 1) = Application.Transpose(t)

.Range("A2:E" & d.Count + 1).Sort key1:=.Range("C6"), order1:=xlAscending, Header:=xlNo

End With

End Sub

Le 05/05/2017 à 09:49

Re

La demande évolue.... 8)

Une proposition

Sub Report_Profil()
Dim Mondico As Object, tablo As Variant, Col&, Rw&

Set Mondico = CreateObject("Scripting.Dictionary")
With Sheets(2)
    tablo = .Range("A2:E" & .Range("A" & Rows.Count).End(xlUp).Row)
    For i = 1 To UBound(tablo)
        If Not Mondico.exists(tablo(i, 1)) Then
            Mondico(tablo(i, 1)) = Mondico.Count + 1
            tablo(Mondico(tablo(i, 1)), 1) = tablo(i, 1)
        End If
        Rw = Mondico(tablo(i, 1))
        For Col = 2 To 4
            tablo(Rw, Col) = tablo(Rw, Col) + tablo(i, Col)
        Next Col
        tablo(Rw, 5) = tablo(Rw, 2) / tablo(Rw, 4)
    Next i
    .[G6].Resize(Mondico.Count, UBound(tablo, 2)) = tablo
End With
Set Mondico = Nothing
End Sub

Cordialement

EDITION: Code plus lisible

Le 05/05/2017 à 10:11

J'avais oublié de remettre la suppression des données et la restitution au même endroit....

Sub Report_Profil()
Dim Mondico As Object, tablo As Variant, Rng As Range, Col&, Rw&

Set Mondico = CreateObject("Scripting.Dictionary")
With Sheets(2)
    Set Rng = .Range("A2:E" & .Range("A" & .Rows.Count).End(xlUp).Row)
End With
tablo = Rng

For i = 1 To UBound(tablo)
    If Not Mondico.exists(tablo(i, 1)) Then
        Mondico(tablo(i, 1)) = Mondico.Count + 1
        tablo(Mondico(tablo(i, 1)), 1) = tablo(i, 1)
    End If
    Rw = Mondico(tablo(i, 1))
    For Col = 2 To 4
        tablo(Rw, Col) = tablo(Rw, Col) + tablo(i, Col)
    Next Col
    tablo(Rw, 5) = tablo(Rw, 2) / tablo(Rw, 4)
Next i

With Rng
    .Clear
    .Resize(Mondico.Count, UBound(tablo, 2)) = tablo
End With

Set Mondico = Nothing
Erase tablo
End Sub
Le 05/05/2017 à 11:28

Le calcul n'est pas bon il me rajoute 3 sur chaque valeur de la colonne B et D, uniquement la colonne C est juste

Je ne trouve pas l'erreur

Le 05/05/2017 à 12:37

Exact.

En fait l'écart correspondait à la première valeur rencontrée.

Une nouvelle version qui règle ce problème:

Sub Report_Profil()
Dim Mondico As Object, tablo As Variant, Rng As Range, Col&, Rw&
Set Mondico = CreateObject("Scripting.Dictionary")
With Sheets(2)
    Set Rng = .Range("A2:E" & .Range("A" & .Rows.Count).End(xlUp).Row)
End With
tablo = Rng
For i = LBound(tablo, 1) To UBound(tablo, 1)
    If Not Mondico.exists(tablo(i, 1)) Then
        Rw = Mondico.Count + 1
        Mondico(tablo(i, 1)) = Rw
        For Col = 1 To 4
            tablo(Rw, Col) = tablo(i, Col)
        Next Col
    Else
        Rw = Mondico(tablo(i, 1))
        For Col = 2 To 4
            tablo(Rw, Col) = tablo(Rw, Col) + tablo(i, Col)
        Next Col
    End If
    tablo(Rw, 5) = tablo(Rw, 2) / tablo(Rw, 4)
Next i
With Rng
    .Clear
    .Resize(Mondico.Count, UBound(tablo, 2)) = tablo
End With
Set Mondico = Nothing: Erase tablo
End Sub

Cordialement

Le 05/05/2017 à 13:06

Bonjour Rouritta, le forum

Salut Efgé

Un poil différent, le calcul de la moyenne est effectué en fin de code :

Attention à la division par zéro, je n'ai pas placé de test.

Option Explicit
Sub test()
Dim a, b(), i As Long, j As Long, n As Long, dico As Object, e
    Set dico = CreateObject("Scripting.Dictionary")
    dico.comparemode = 1
    With Sheets("Ressources Net").Cells(1).CurrentRegion
        a = .Value
        ReDim b(1 To UBound(a, 1), 1 To UBound(a, 2) + 1)
        For i = 1 To UBound(a, 1)
            If Not dico.exists(a(i, 1)) Then
                n = n + 1
                For j = 1 To UBound(a, 2)
                    b(n, j) = a(i, j)
                Next
                dico.Item(a(i, 1)) = n
            Else
                For j = 2 To UBound(a, 2)
                    b(dico.Item(a(i, 1)), j) = b(dico.Item(a(i, 1)), j) + a(i, j)
                Next
            End If
        Next
        For Each e In dico.keys
            b(dico.Item(e), UBound(b, 2)) = b(dico.Item(e), 2) / b(dico.Item(e), 4)
        Next
        With .Offset(, .Columns.Count + 2).Resize(n, UBound(b, 2))
            .Value = b
        End With
    End With
    Set dico = Nothing
End Sub

klin89

Le 05/05/2017 à 13:21

Salut Klin89

Bonne idée. Une boucle sur le tableau final économisera pas mal de calculs (1 000 et quelques dans l'exemple).

J'adopte et j'ajoute la vérification du risque de division par 0 :

Sub Report_Profil()
Dim Mondico As Object, tablo As Variant, Rng As Range, Col&, Rw&
Set Mondico = CreateObject("Scripting.Dictionary")
With Sheets(2)
    Set Rng = .Range("A2:E" & .Range("A" & .Rows.Count).End(xlUp).Row)
End With
tablo = Rng
For i = LBound(tablo, 1) To UBound(tablo, 1)
    If Not Mondico.exists(tablo(i, 1)) Then
        Rw = Mondico.Count + 1
        Mondico(tablo(i, 1)) = Rw
        For Col = 1 To 4
            tablo(Rw, Col) = tablo(i, Col)
        Next Col
        tablo(Rw, Col) = ""
    Else
        Rw = Mondico(tablo(i, 1))
        For Col = 2 To 4
            tablo(Rw, Col) = tablo(Rw, Col) + tablo(i, Col)
        Next Col
    End If
Next i
For Rw = 1 To Mondico.Count
    If tablo(Rw, 4) > 0 Then tablo(Rw, 5) = tablo(Rw, 2) / tablo(Rw, 4)
Next Rw
With Rng
    .Clear
    .Resize(Mondico.Count, UBound(tablo, 2)) = tablo
End With
Set Mondico = Nothing: Erase tablo
End Sub

Cordialement

Le 05/05/2017 à 14:05

Bonjour Klin89 et Efgé

j'ai l'impression il marche très bien le code

Merci pour votre aide

Le 05/05/2017 à 14:06
Le 06/05/2017 à 13:50

Bonjour Efgé, Bonjour Klin89

je voulais déterminer la somme Total de ma colonne 4, avez vous une idée ?

Bon week end

Le 06/05/2017 à 16:09

Re Rouritta, 

With Rng
    .Clear
    .Resize(Mondico.Count, UBound(tablo, 2)) = tablo
    With .CurrentRegion
        .Resize(1, 1).Offset(.Rows.Count, 3).Formula = _
        "=sum(" & .Columns(4).Address(0, 0) & ")"
    End With
End With

klin89

Le 09/05/2017 à 10:11

Bonjour,

ça marche pas

Le 09/05/2017 à 10:27

Voici le code de ma macro

Sub Pourcentage()

With Sheets("Code Budget")

Set Rng = .Range("C6:H" & .Range("C" & .Rows.Count).End(xlUp).Row)

End With

tablo = Rng

With Rng

.Resize(Mondico.Count, UBound(tablo, 2)) = tablo

With .CurrentRegion

.Resize(1, 1).Offset(.Rows.Count, 3).Formula = _

"=sum(" & .Columns(4).Address(0, 0) & ")"

End With

End With

End Sub

Le 09/05/2017 à 11:18

Bonjour Rouritta, Bonjour Klin89

Rouritta a écrit :

Voici le code de ma macro

Sub Pourcentage()

With Sheets("Code Budget")

Set Rng = .Range("C6:H" & .Range("C" & .Rows.Count).End(xlUp).Row)

End With

tablo = Rng

With Rng

.Resize(Mondico.Count, UBound(tablo, 2)) = tablo

With .CurrentRegion

.Resize(1, 1).Offset(.Rows.Count, 3).Formula = _

"=sum(" & .Columns(4).Address(0, 0) & ")"

End With

End With

End Sub

Tu n'aurais pas oublié tout le milieu de la macro,des fois? .......

Encore un coup il serai plus simple d'avoir un fichier exemple....

Cordialement

Le 09/05/2017 à 12:10

Bonjour,

Merci

J'ai fait ça et ça marche bien

[G65536].End(xlUp).Offset(1, 0).Formula = "=SUM(G6:G" & [G65536].End(xlUp).Row & ")"

'Division G6/Total G

[H6].Formula = "=G6/G$" & [G65536].End(xlUp).Row

'Recopie vers le bas

[H6].AutoFill Range("H6:H" & [G65536].End(xlUp).Row)

Range("H6:H" & [G65536].End(xlUp).Row).NumberFormat = "0.00%"

Merci beaucoup

@ Efgé, en fait c'étais une autre macro c'est pour cela que j'ai pas utilisé tout le code

là j'ai plus des modif à faire

Merci Encore Efgé, Klin89

Rechercher des sujets similaires à "trier doublons colonne additionnant"