Trier, suprimer les doublons en additionant les valeurs des cellules voisines [Résolu]

[alex santus]

Bnojour à tous,

Voici mon problème,

Dans une feuille je récupere une liste ( je simplifie pour que ce soit plus compréhensible sinon il y a plus de colonne) col A " nom " col B " produits" col C "quantité"

Je voudrai que ma macro boucle sur cette liste qu il compare les colonne A et B sont identique qu il additonne les C et supprime la ligne testé.

pour l instant voici un peut ou j en suis !

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
lageFactureOuverte = "a2:a" & WSFactureOuverte.Range("a65536").End(xlUp).Row
 
                For Each CelTestDansFactureOuvert In Range(PlageFactureOuverte)
                For Each CelCibleFactureOuvert In Range(PlageFactureOuverte)
 
 
                If CelTestDansFactureOuvert = CelCibleFactureOuvert.Offset(1, 0) And CelTestDansFactureOuvert.Offset(0, 2) _
                = CelCibleFactureOuvert.Offset(1, 2) Then
 
 
 
 
 
                        CelTestDansFactureOuvert.Offset(0, 3) = CelTestDansFactureOuvert.Offset(0, 3) _
                        + CelCibleFactureOuvert.Offset(1, 3)
                        CelTestDansFactureOuvert.Offset(0, 4) = CelTestDansFactureOuvert.Offset(0, 4) _
                        + CelCibleFactureOuvert.Offset(1, 4)
                        CelTestDansFactureOuvert.Offset(0, 6) = CelTestDansFactureOuvert.Offset(0, 6) _
                        + CelCibleFactureOuvert.Offset(1, 6)
                        CelTestDansFactureOuvert.Offset(0, 7) = CelTestDansFactureOuvert.Offset(0, 7) _
                        + CelCibleFactureOuvert.Offset(1, 7)
 
 
 
                    WSFactureOuverte.Range("a" & CelCibleFactureOuvert.Offset(1, 0).Row & ":" & "z" & CelCibleFactureOuvert.Offset(1, 0).Row).ClearContents
 
                End If
                Next CelCibleFactureOuvert
 
        Next CelTestDansFactureOuvert

Voila si quelqu un saurrai me re-mettre sur la bonne voie, car a force d essayé je commence a faire n importe quoi.

d avance merci

[faraudch]

Bonjour,
Peux tu rajouter tes définitions de variables pour que l'on puisse tester.
cordialement.

[alex santus]

Bonjour faraudch,

Voici les deux varaible plage en plus

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
Sub ListingFactureImpaye()
 
 
 
Dim PlageVente As String
Dim CelTestDansFactureOuvert As Range
Dim PlageFactureOuverte As String
Dim CelCibleFactureOuvert As Range
 
 
 
 
 
                PlageVente = "a2:a" & WSvente.Range("a65536").End(xlUp).Row
 
 
                PlageFactureOuverte = "a2:a" & WSFactureOuverte.Range("a65536").End(xlUp).Row
 
                For Each CelTestDansFactureOuvert In Range(PlageFactureOuverte)
                For Each CelCibleFactureOuvert In Range(PlageFactureOuverte)
 
 
 
 
                If CelTestDansFactureOuvert = CelCibleFactureOuvert.Offset(1, 0) And CelTestDansFactureOuvert.Offset(0, 2) _
                = CelCibleFactureOuvert.Offset(1, 2) Then
 
 
 
 
 
                        CelTestDansFactureOuvert.Offset(0, 3) = CelTestDansFactureOuvert.Offset(0, 3) _
                        + CelCibleFactureOuvert.Offset(1, 3)
                        CelTestDansFactureOuvert.Offset(0, 4) = CelTestDansFactureOuvert.Offset(0, 4) _
                        + CelCibleFactureOuvert.Offset(1, 4)
                        CelTestDansFactureOuvert.Offset(0, 6) = CelTestDansFactureOuvert.Offset(0, 6) _
                        + CelCibleFactureOuvert.Offset(1, 6)
                        CelTestDansFactureOuvert.Offset(0, 7) = CelTestDansFactureOuvert.Offset(0, 7) _
                        + CelCibleFactureOuvert.Offset(1, 7)
 
                End If
 
            Next CelCibleFactureOuvert
        Next CelTestDansFactureOuvert

j espere que tu y verra plus clair

[faraudch]

WSvente, WSFactureOuverte, non definis.
Il y en a peut être d'autres.
ch = christian.
A+.

[alex santus]

en fait WSvente et WSFactureOuverte sont les nom de mes deux feuilles en vba
, tu peut les remplacer par feuill1 et feuill2.
je ne pense pas que je peux les declarer.
A+

[faraudch]

C'est l'heure de manger.
Par contre si ta macro était commantée, je comprendrais mieux.
Bon app.

Essaye ça, ça devrairt marcher.

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
Dim CelTestColA As Range
Dim PlageFactureOuverteColA As String
Dim TotalIntermediaire As Integer
Dim DebutLigneSuppression As Integer
Dim LastCell As Integer
 
Sub test()
 
 'on trie sur le nom de la 1) et de la 2° colonne
 Range("a1").Select
      Selection.Sort Key1:=Range("A2"), Order1:=xlAscending, Key2:=Range("B2") _
        , Order2:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:= _
        False, Orientation:=xlTopToBottom
 
    'on fait les totaux en cas d'égalité de cola et colb
 
                PlageFactureOuverteColA = "a2:a" & Range("a65536").End(xlUp).Row
                LastCell = Range("a65536").End(xlUp).Row
 
                For Each CelTestColA In Range(PlageFactureOuverteColA)
                    If CelTestColA = CelTestColA.Offset(1, 0) Then
                        If CelTestColA.Offset(0, 1) = CelTestColA.Offset(1, 1) Then
                    TotalIntermediaire = CelTestColA.Offset(0, 2).Value + CelTestColA.Offset(1, 2).Value
                    CelTestColA.Offset(1, 2).Value = TotalIntermediaire
                    CelTestColA.Offset(0, 2).Value = 0
                    End If
                    End If
 
            Next
 
            'on efface les lignes inutiles
        Selection.Sort Key1:=Range("C2"), Order1:=xlDescending, Header:=xlGuess, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
 
    Columns("C:C").Select
 
    Selection.Find(What:="0", After:=ActiveCell, LookIn:=xlFormulas, LookAt _
        :=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
        False).Activate
        DebutLigneSuppression = ActiveCell.Row
 
    Range("A" & DebutLigneSuppression & ":C" & LastCell).Select
    Selection.Delete Shift:=xlUp
 
            'on retrie sur la première colonne
 
                Selection.Sort Key1:=Range("A2"), Order1:=xlAscending, Key2:=Range("B2") _
        , Order2:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:= _
        False, Orientation:=xlTopToBottom
  End Sub

[mercatog]

Ci-joint une proposition
on ajoute à la fin une colonne où on concatène l'ensemble des colonnes à comparer (ici colonne A: nom et colonne B: produit)
on tri
on fais le cumul
on supprime les lignes en doubles
on efface la colonne ajoutée!
le code ci-joint est testé sur un exemple! à adapter à ton cas

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
Sub Cumul()
Dim LastLig As Long, i As Long
With Sheets("WSv")
    LastLig = .Cells(Rows.Count, 1).End(xlUp).Row
    For i = 2 To LastLig
        .Range("D" & i).Value = .Range("A" & i).Value & .Range("B" & i).Value
    Next i
    .Range("A2:D" & LastLig).Sort key1:=.Range("D2"), order1:=xlAscending, header:=xlNo
 
    For i = LastLig To 3 Step -1
        If .Range("D" & i - 1).Value = .Range("D" & i).Value Then
            .Range("C" & i - 1).Value = .Range("C" & i).Value + .Range("C" & i - 1).Value
            .Rows(i).Delete
        End If
    Next i
.Columns("D:D").Clear
End With
End Sub

[faraudch]

La même macro avec correction d'un petit bug.

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
Dim CelTestColA As Range
Dim PlageFactureOuverteColA As String
Dim TotalIntermediaire As Integer
Dim DebutLigneSuppression As Integer
Dim LastCell As Integer
 
Sub test()
 
 'on trie sur le nom de la 1) et de la 2° colonne
 Range("a1").Select
      Selection.Sort key1:=Range("A2"), order1:=xlAscending, Key2:=Range("B2") _
        , Order2:=xlAscending, header:=xlGuess, OrderCustom:=1, MatchCase:= _
        False, Orientation:=xlTopToBottom
 
    'on fait les totaux en cas d'égalité de cola et colb
 
                PlageFactureOuverteColA = "a2:a" & Range("a65536").End(xlUp).Row
                LastCell = Range("a65536").End(xlUp).Row
 
                For Each CelTestColA In Range(PlageFactureOuverteColA)
                    If CelTestColA = CelTestColA.Offset(1, 0) Then
                        If CelTestColA.Offset(0, 1) = CelTestColA.Offset(1, 1) Then
                    TotalIntermediaire = CelTestColA.Offset(0, 2).Value + CelTestColA.Offset(1, 2).Value
                    CelTestColA.Offset(1, 2).Value = TotalIntermediaire
                    CelTestColA.Offset(0, 2).Value = 0
                    End If
                    End If
 
            Next
 
            'on efface les lignes inutiles
        Selection.Sort key1:=Range("C2"), order1:=xlDescending, header:=xlGuess, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
 
       'on cherche la première cellule = à 0
    For i = 2 To LastCell
        If Range("c" & i).Value = 0 Then
                Range("c" & i).Select
                DebutLigneSuppression = ActiveCell.Row
                Exit For
                End If
 
    Next
 
    Range("A" & DebutLigneSuppression & ":C" & LastCell).Select
    Selection.Delete Shift:=xlUp
 
            'on retrie sur la première colonne
 
                Selection.Sort key1:=Range("A2"), order1:=xlAscending, Key2:=Range("B2") _
        , Order2:=xlAscending, header:=xlGuess, OrderCustom:=1, MatchCase:= _
        False, Orientation:=xlTopToBottom
End Sub

[p0l1n]

jai eu une application qui ressemblait a ce que tu veux faire, et une solution simple qui enleve les doublons et additions tout tes résultats est un tableau dynamique

pour ton tableau dans la colonne, mais tes données de la colA et les données de la ColB, et dans la case value met les valeurs de ta ColC.

si tu utilise un bouton ou autre pour le traitement de tes données jai commencé ma macro en mettant à jour le tableau dynamique comme suis :

Code :

1
2
Set pvtTable = ActiveSheet.Range("Case de ton tableau").PivotTable
pvtTable.RefreshTable

ensuite traite ton tableau comme bon te semble, et tes données se mettent à jour et sont classés sans doublons.

Bonne journée !

[alex santus]

Bonsoir à vous deux,

désolé de n avoir pas été plus réactif mes j était absent de chez moi.
je viens de rentrer et je me suis empresser a mettre en œuvre les solution proposé.

Mercatog, j ai essayé le tienne en premier car elle me paraissait plus facile a mettre en ordre par rapport au vrai cellule que je trie.

et la comme par magie tout c est mis la ou je le voulais, mon problème c est que je n avais bien compris que pour faire un tri comme cela il fallait commencer par la dernière ligne additionner et supprimer au fur et a mesure. enfin après deux jour que je m arrache les cheveux ca marche. mille merci pour ton aide.

Faraudch

comme tu peut le lire ci dessus j ai commencer par le code de mercatog car c était plus simple pour moi de l adapter rapidement,
ceci dit demain je ferrai quelque essai avec le tiens.
pour pouvoir comprendre une autre approche pour réalisé ce tri.

merci a toi aussi de t être penchée sur mon problème.

à bientôt et bonne soirée

Alex