VBA_Suppression & addition_Doublons

Version imprimable

09/03/2016, 12h05
Esculape

VBA_Suppression & addition_Doublons

Bonjour le forum!

Après quelques jours de recherches et d'essais non concluants, je viens poser ma question qui concerne un point précis de la gestion des doublons en VBA.

Mon problème est le suivant:
- je dois supprimer des doublons dans certaines colonnes et additionner les valeurs dans d'autres colonnes si les premières colonnes ont été détectées en tant que doublons,
- les données en double peuvent être à n'importe quelle ligne dans la feuille de calcul,
- seules les données en doublon d'une colonne (dans l'exemple ici la colonne A) sont déterminants pour déclencher l'action,
- cette opération doit être légère, car elle est intégrée à un autre code.

Mon cas donnerait ainsi à peu près cela (avant / après):

A B C D

Donnée1 Donnée1.1 10 34

Donnée1 Donnée1.1 26 52

Donnée2 Donnée2.1 20 26

Donnée1 Donnée1.1 10 2

A B C D

Donnée1 Donnée1.1 46 88

Donnée2 Donnée2.1 20 26

J'ai lu par exemple quelques fils faisant référence à la méthode Highlander développée par rdurupt, mais j'avoue ne pas avoir réussi à l'adapter à mon cas précis.

N'hésitez pas à me demander plus d'informations sur le cas si celui-ci n'est pas assez détaillé.

Bonne journée à tous!

Esculape.

1 pièce(s) jointe(s)

Sommer et eliminer doublons

Bonjour,

Je te suggère ce type de code pour traiter la liste... Tri sur colonne A puis 2 boucles imbriquées. Pas trop lourd !

Encore une fois, pour les pros VBA, y a bien sûr plus efficace mais l'objectif est aussi d'être pédagogue...

Cordialement.

Bruno

Pièce jointe 203391

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
 
Option Explicit
 
Sub SommeDoublons()
Dim Cumul1 As Long
Dim Cumul2 As Long
Dim Groupe As String
 
'Fige écran
Application.screenupdating=false
 
'Tri par Groupe
    Range("A16").Select
    ActiveWorkbook.Worksheets("Feuil1").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Feuil1").Sort.SortFields.Add Key:=Range("A15"), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Feuil1").Sort
        .SetRange Range("A15:D" & Range("A15").End(xlDown).Row)
        .Header = xlYes
        .Apply
    End With
'Traite doublons
Range("A16").Activate
Do While ActiveCell <> "" 'Parcours toute la liste
    Groupe = ActiveCell
    Cumul1 = ActiveCell.Offset(0, 2)
    Cumul2 = ActiveCell.Offset(0, 3)
 
    Do While ActiveCell.Offset(1, 0) = Groupe 'Tant qu'il existe un doublon sur Groupe
        'Cumuler valeurs
        Cumul1 = Cumul1 + ActiveCell.Offset(1, 2)
        Cumul2 = Cumul2 + ActiveCell.Offset(1, 3)
        'Supprimer le doublon
        ActiveCell.Offset(1, 0).EntireRow.Delete
    Loop
    'Reporter cumuls sur ligne restante
    ActiveCell.Offset(0, 2) = Cumul1
    ActiveCell.Offset(0, 3) = Cumul2
 
    'Passer au groupe suivant
    ActiveCell.Offset(1, 0).Select
Loop
 
End Sub

Bonjour,
Sur excel sa ressemble à la formule sommeprod : résultat en 6è et 7è ligne du tableau

Donnée1 Donnée1.1 10 34

Donnée1 Donnée1.1 26 52

Donnée2 Donnée2.1 20 26

Donnée1 Donnée1.1 10 2

A B C D

Donnée1 Donnée1.1 46 88 =SOMMEPROD((A1:A4=A3)*(B1:B4=B3);(C1:C4)) =SOMMEPROD((A1:A4=A1)*(B1:B4=B1);(D1: D4))

Donnée2 Donnée2.1 20 26 =SOMMEPROD((A1:A4=A3)*(B1:B4=B3);(C1:C4)) =SOMMEPROD((A1:A4=A3)*(B1:B4=B3);(D1: D4))

j'ai commencé un post sur les doublons qui pourrait te servir : http://www.developpez.net/forums/d15...ns-specifique/
En te basant en vba sur le principe de sommeprod tu pourrais sauvegarder la somme de tous les (Donnée1, Donnée1.1) et tous les (Donnée2, Donnée2.1) … avec une recherche des doublons, stockage de leurs somme, suppression des doublons puis copier les sommes sur les occurences correspondantes

désolé je n'ai pas vraiment le temps de faire qq chose en vba (cause mon post me prends déjà bcp de temps) mais je pense que la solution est proche de ce que tu peux trouver dans mon post
cordialement

re,

en vba schématiquement on aurait (désolé si c'est pas très bien formulé) :

• Recherche des doublons de (Col A(i) et Col B(i)) dans ta plage
• pour chaque doublons trouvés, stock les valeurs de (col C(i), Col D(i))
• qd le scan de ta plage est terminé, suppression des doublons
• et faire correspondre la somme des doublons pour (Col A(i) et Col B(i)) en (col C(i), Col D(i))
(les autres données n'ayant pas de doublons, resteront avec leurs valeurs)

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
Sub SupprimerDoublon()
Dim Init As Boolean
Dim MyRange As Range
Dim L As Long
Dim I As Long
Dim lignes() As Long
Set MyRange = ActiveSheet.UsedRange
Debug.Print "Sur  colonne A"
For L = 1 To MyRange.Rows.Count
   If Highlander(Init, MyRange(L, 1)) = True Then
    ReDim Preserve lignes(I)
    lignes(I) = L
    I = I + 1
   End If
Next
 
For I = UBound(lignes) To 0 Step -1
    MyRange(lignes(I), 1).EntireRow.Delete
Next
End Sub
Function Highlander(Init As Boolean, ParamArray Plage()) As Boolean
'..................................................
'La méthode Highlander, il ne peut en rester qu'un.
'Retourne True si doublon.
'..................................................
 
Static CollectDoublon As Collection
Dim T As String
Dim PlageIndex As Long
Dim myPlage As Range
Dim Col As Integer
If Init = False Then
Init = True
   Set CollectDoublon = Nothing
   Set CollectDoublon = New Collection
End If
 
 
T = "T"
For PlageIndex = 0 To UBound(Plage)
   Set myPlage = Plage(PlageIndex)
   For Col = 1 To myPlage.Columns.Count
    T = T & "_" & myPlage(1, Col)
   Next
Next
On Error Resume Next
CollectDoublon.Add T, T
If Err <> 0 Then Highlander = True
On Error GoTo 0
End Function
Sub DeleteRow(MyRange As Range)
Dim DelRow As String
DelRow = CStr(MyRange.Row) & ":" & CStr(MyRange.Row)
Debug.Print DelRow
    ActiveSheet.Rows(DelRow).Delete Shift:=xlUp
 
 
End Sub

09/03/2016, 18h03
Marc-L

Bonjour, bonjour !

Citation:

Envoyé par Esculape

- cette opération doit être légère, car elle est intégrée à un autre code.

Elle ne le sera pas forcément, tout dépend déjà de l'intelligence de conception de la feuille de calculs contenant les données !

Joindre un classeur exemple en .xlsx (sans code donc) contenant une feuille avant et une feuille après
en précisant si les données doivent remplacer celles de la feuille source ou alimenter une autre feuille …

______________________________________________________________________________________________________
Je suis Paris, Charlie, …
09/03/2016, 18h20
Esculape
Merci pour ces réponses!

J'ai testé le code ZX12R, mais je bloque sur quelques points. Le débogueur me dit que As Long de Cumul2 ne convient pas. Cela marche avec un String (peut-être trop vaste comme définition?).
Mais je n'obtiens toujours pas une addition des deux dernières colonnes si doublon.

Citation:

• Recherche des doublons de (Col A(i) et Col B(i)) dans ta plage
• pour chaque doublons trouvés, stock les valeurs de (col C(i), Col D(i))
• qd le scan de ta plage est terminé, suppression des doublons
• et faire correspondre la somme des doublons pour (Col A(i) et Col B(i)) en (col C(i), Col D(i))
(les autres données n'ayant pas de doublons, resteront avec leurs valeurs)

Voilà c'est ça RyuAutodidacte. Sauf que je n'aurais même besoin que de ce qui est présent dans la Colonne A.

Merci rdurupt pour l'adaptation du code. Cependant il semble boucler sans fin à la suite du Next ici...
Code:

1 2 3 4 For I = UBound(lignes) To 0 Step -1 MyRange(lignes(I), 1).EntireRow.Delete Next End Sub
Marc-L, merci de ta réponse, je te ferai parvenir ce fichier demain dans la matinée pour que tu puisses cerner le problème.

Bonne soirée le forum!

Esculape.

P.S.: Je ne pourrai répondre que demain dans la matinée.
10/03/2016, 14h20
Esculape

1 pièce(s) jointe(s)

Bonjour le forum!

Pris par le temps, je n'ai pas pu répondre ce matin.
Mais voici le fichier d'exemple promis: Pièce jointe 203497

L'idée est donc d'additionner le résultat, lorsqu'il s'agit de doublons, des colonnes C et D tout en supprimant le contenu en doublon des cellules A, B et C.

Esculape.

P'tite démonstration !

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
Sub Demo()
        VA = Feuil1.Cells(1).CurrentRegion.Value
        If UBound(VA, 2) < 5 Then Beep: Exit Sub
        ReDim VR(1 To UBound(VA), 1 To 5)
        For C% = 1 To 5:  VR(1, C) = VA(1, C):  Next
    With CreateObject("Scripting.Dictionary")
        For R& = 2 To UBound(VA)
            If .Exists(VA(R, 2)) Then
                      L& = .Item(VA(R, 2))
                VR(L, 4) = VR(L, 4) + VA(R, 4)
                VR(L, 5) = VR(L, 5) + VA(R, 5)
            Else
                L = .Count + 2
                .Add VA(R, 2), L
                For C = 1 To 5:  VR(L, C) = VA(R, C):  Next
            End If
        Next
             Feuil2.UsedRange.Clear
        With Feuil2.[A1:E1].Resize(.Count + 1)
            .Value = VR
            .Columns.AutoFit
            Application.Goto .Cells(1), True
        End With
            .RemoveAll
    End With
End Sub

______________________________________________________________________________________________________

Merci de cliquer sur :plusser: pour chaque message ayant aidé puis sur :resolu: pour clore cette discussion …

10/03/2016, 18h00
Esculape

Génial Marc-L ça marche super!!

Je tente de l'adapter ce soir (copie sur même feuille notamment) et je vous tiens au courant.
Merci de votre réactivité!!

Bonne soirée,

Esculape.

Variante fonctionnant aussi sur MAC !

Ici la feuille source est directement modifiée :

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
Sub DemoC()
        Dim cLig As New Collection, C As Byte, L&, R&, VA, VR
    With Feuil1
        VA = .Cells(1).CurrentRegion.Value
        If UBound(VA, 2) < 5 Then Beep: Exit Sub
        ReDim VR(1 To UBound(VA) - 1, 1 To 5)
    For R = 2 To UBound(VA)
           On Error Resume Next
           L = cLig(VA(R, 2))
           On Error GoTo 0
        If L Then
            VR(L, 4) = VR(L, 4) + VA(R, 4)
            VR(L, 5) = VR(L, 5) + VA(R, 5)
        Else
            L = cLig.Count + 1
            cLig.Add L, VA(R, 2)
            For C = 1 To 5:  VR(L, C) = VA(R, C):  Next
        End If
                L = 0
    Next
        If cLig.Count < UBound(VR) Then
            .[A2:E2].Resize(cLig.Count).Value = VR
            .Rows(cLig.Count + 2 & ":" & UBound(VA)).Delete
        End If
    End With
        Set cLig = Nothing
End Sub

______________________________________________________________________________________________________

Merci de cliquer sur :plusser: pour chaque message ayant aidé puis sur :resolu: pour clore cette discussion …

15/03/2016, 16h41
Esculape

Merci!

Bonjour le Forum,

Merci à tous pour vos réponses :D!!
Ce site est une véritable mine d'or il faut le dire, et accessible qui plus est!

J'ai réussi à mener à terme mon projet grâce à votre aide précieuse!

Bonne journée à tous.

Esculape.

A	B	C	D
Donnée1	Donnée1.1	10	34
Donnée1	Donnée1.1	26	52
Donnée2	Donnée2.1	20	26
Donnée1	Donnée1.1	10	2