Reformater une luste en fonction des doublons

[Ossecour]

Bonjour à tous,

Bien sûr, je suis encore dans les choux !

Vous trouverez ci-dessous un extrait de la liste que je cherche à "reformater", c'est à dire :
Colonne A des numéros de facture triés par ordre croissant.
Colonne B des montants, correspondant à ces factures.
Problème : Parfois, dans la colonne A deux lignes avec le même n° de facture, mais pas avec le même montant dans la colonne B.
Je voudrais recopier ces deux colonnes dans la même feuille mais en additionnant les montants de la colonne B (s'ils ne sont pas égaux, c'est à dire doublons eux même) correspondant aux "doublons" de la colonne A

J'ai fait des formules, mais je n'arrive pas à tenir compte de tout ce que je veux.

Je vous remercie d'avance pour votre aide précieuse.

Cordialement

Ossecour

 

[Victor21]

Re : Reformater une luste en fonction des doublons

Bonjour, ossecour.

Voir pj :

Complément : En VBA

Sub FiltreCompteEtTrie()
    Dim cell As Range

    Columns("A:A").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("F1"), Unique:=True
    For Each cell In Range("G2:G1000")
        If cell.Offset(0, -1).Value <> "" Then
            cell.FormulaR1C1 = _
            "=SUMPRODUCT((R2C[-5]:R1000C[-5])*(R2C[-6]:R1000C[-6]=RC[-1]))"
        End If
    Next
    Columns("F:G").Sort Key1:=Range("F2"), Order1:=xlAscending, Header:=xlGuess

End Sub

 

[Ossecour]

Re : Reformater une luste en fonction des doublons

Bonsoir Victor21,

Je viens de prendre connaissance de ta réponse et je t'en remercie, je vais tester de ce pas et je ne manquerai pas de te tenir au courant.

Merci encore et bonne soirée !

Cordialement

Ossecour

 

[Ossecour]

Re : Reformater une luste en fonction des doublons

Victor21,

Alors, je viens de tester et c'est presque parfait, la seule chose qui m'ennuie un peu, c'est que j'avais précisé dans ma demande initiale : "Je voudrais recopier ces deux colonnes dans la même feuille mais en additionnant les montants de la colonne B (s'ils ne sont pas égaux, c'est à dire doublons eux même) correspondant aux "doublons" de la colonne A".

Dans mon exemple, je crois que les deux premières lignes sont dans ce cas là, et c'est dans ce cas précis que je voudrais qu'elles se reportent sans s'additionner.

Cordialement

Ossecour

 

[R@chid]

Re : Reformater une luste en fonction des doublons

Salut tout le monde,
Selon ce que j'ai compris, tu vas va passer par Filtre Elabore pour extraire la liste ==> recopier vers un autre emplacement , cocher extraire sans doublons et ultiliser la fonction SOMMEPROD pour les calculs

 

[Ossecour]

Re : Reformater une luste en fonction des doublons

Bonsoir Rachid,

Je te remercie de ta réponse, mais là où est mon gros problème c'est que je souhaiterais, lorsque, comme dans mon exemple, les lignes 1 et 2 sont complètement identiques A1=A2 et B1=B2, je voudrais que dans ce cas là et seulement celui la, le B, ne s'additionnent pas.

Car dans ce cas les B sont eux mêmes des doublons.

Cordialement

Ossecour

 

[Victor21]

Re : Reformater une luste en fonction des doublons

Re, Ossecour. Bonjour, Rachid.

Donc si, cette fois, j'ai bien tout compris comme il faut, et avant de filtrer, il faut supprimer les doublons.
Une colonne sup, c'est possible ?
Une boucle en partant du bas et en comparant les valeurs avec celles du dessus serait plus simple et plus élégant, mais ce n'est pas mon fort.


Un essai en PJ :

 

[Monique]

Re : Reformater une luste en fonction des doublons

Bonjour,

Un essai par formules en pièce jointe,
plus un format conditionnel pour vérifier (pour repérer + vite les doublons)

 

[KenDev]

Re : Reformater une luste en fonction des doublons

Bonsoir Ossecour, Victor, Rachid,

Une solution sans colonnes intermédiaire mais avec le désavantage de l'obligation que les données soient triées par colonne A puis B.

Option Explicit
Sub test()
    Dim tb#(), Rw&, i&, j&, r&
    Rw = Cells(Rows.Count, 1).End(xlUp).Row
    ReDim tb(2 To Cells(Rows.Count, 1).End(xlUp).Row, 1 To 3)
    For i = 2 To UBound(tb)
        tb(i, 1) = Cells(i, 1): tb(i, 2) = Cells(i, 2)
        For j = 2 To i - 1
            If tb(i, 1) = Cells(j, 1) Then
                tb(i, 3) = j
                If tb(i, 2) = Cells(j, 2) Then
                    tb(i, 3) = UBound(tb) + 1
                End If
            End If
        Next j
    Next i
    r = 1
    Cells(1, 4) = Cells(1, 1)
    Cells(1, 5) = Cells(1, 2)
    For i = 2 To UBound(tb)
        If tb(i, 3) = 0 Then
            r = r + 1
            Cells(r, 4) = tb(i, 1)
            Cells(r, 5) = tb(i, 2)
        Else
            If tb(i, 3) <> UBound(tb) + 1 Then
                For j = 2 To r
                    If tb(i, 1) = Cells(j, 4) Then
                        Cells(j, 5) = Cells(j, 5) + tb(i, 2)
                        Exit For
                    End If
                Next j
            End If
        End If
    Next i
End Sub

Cordialement

KD

Edit : bonsoir Monique

 

[Ossecour]

Re : Reformater une luste en fonction des doublons

Bonsoir Monique, KenDev et Rebonsoir Victor et Rachid,


Je suis très touchée par tant de bonne volonté et de bonnes idées !!!

Je viens de tester vos trois méthodes, qui sont toutes aussi efficaces les unes que les autres .

Puisque j'ai l'embarras du choix .... et bien je ne choisirai pas. Je les garde toutes les trois (elles sont trop précieuses) et je changerai en fonction de l'humeur

Je vous remercie vraiment du fond du coeur et vous souhaite une excellente soirée.

Cordialement

Ossecour Merci ! Merci ! Merci !

 

[Ossecour]

Re : Reformater une luste en fonction des doublons

Bonjour, c'est Ossecour ... le reour !


Alors, si mes test d'hier soir étaient très bons sur l'exemple que je vous avais fourni, dans le vrai fichier, j'ai eu des plantages "Excel ne répond plus", "pas de réponse", ou alors, l'ordi recalcule tout pendant 5 minutes au moindre mouvement de souris.

Je me suis permise de modifier des longueurs de plage, 1000 dans le document de Victor, que j'ai passé à 50000, rien su faire dans le document de KenDev et "étendue" sur des plages ensoleillées ... euh pardon , sur des plages plus grandes, des formules de Monique.

Car ma liste actuelle comporte 20000 lignes et risque de doubler.

J'ai vraiment besoin de vos conseils.

Bien Cordialement

Ossecour, Ossecour !

 

[Victor21]

Re : Reformater une luste en fonction des doublons

Re,

On gagne un peu de temps avec

Application.ScreenUpdating = False

en début de macro.
Pour 10000 valeurs, la macro boucle chez moi en 43''.

J'ai remplacé les formules par leurs valeurs, et supprimé la colonne intermédiaire en fin de procédure.

 

[Monique]

Re : Reformater une luste en fonction des doublons

Bonjour,

Une macro que m’avait faite ChTi160

La macro :
copie A2:B2
colle A2:B2 sur A3:B20000
copie ce qu'elle vient de coller
colle seulement le résultat
(il n'y a plus donc plus que 2 formules dans la feuille : A2 et B2)
supprime les lignes où il y a un 0 en colonne A

Passe aussi en mode de calcul sur ordre
et revient en mode de calcul automatique

32 secondes pour 20 000 lignes chez moi

 

[Ossecour]

Re : Reformater une luste en fonction des doublons

Re Bonjour,


Je vous remercie pour tant de gentillesse et de réactivité, je fais mes essais dans l'après midi et je vous tiens informés.

Bonne après midi à vous tous.

Merci encore !

Ossecour

 

[KenDev]

Re : Reformater une luste en fonction des doublons

Bonjour à tous,

Effectivement la macro, proposée hier n'était particulièrement pas adaptée pour de grands tableaux. Celle ci fait le travail sur 50000 lignes en un peu moins de 30 secondes.
Cordialement

KD

Option Explicit

Sub test2()
Dim Rw1&, Rw2&, i&
'A lancer depuis la feuille contenant les données en colonne A et B
'Les données doivent être triées selon colonne A puis B
Application.ScreenUpdating = False
Rw1 = Cells(Rows.Count, 1).End(xlUp).Row
Cells(1, 4) = Cells(1, 1)
Cells(1, 5) = Cells(1, 2)
Rw2 = 1
For i = 2 To Rw1
    If Cells(i, 1) = Cells(i - 1, 1) Then
        If Cells(i, 2) <> Cells(i - 1, 2) Then Cells(Rw2, 5) = Cells(Rw2, 5) + Cells(i, 2)
    Else
        Rw2 = Rw2 + 1
        Cells(Rw2, 4) = Cells(i, 1)
        Cells(Rw2, 5) = Cells(i, 2)
    End If
Next i
Application.ScreenUpdating = True
End Sub