XL 2016 [RESOLU] Extraction sans doublon et calcul sur une colonne

ivan27

XLDnaute Occasionnel
Bonsoir à tous,

Comme spécifié dans le titre, j'ai une liste de données qui comprend des nombreux doublons.
Je souhaiterais éliminer les doublons, faire un calcul puis conserver finalement une seule ligne.
J'ai expliquer au mieux mon besoin dans le fichier joint.
N'hésitez pas à revenir vers moi si je ne suis pas suffisamment précis.
Merci d'avance pour votre aide
Bonne soirée

Ivan
 

Pièces jointes

  • essai.xlsx
    62.9 KB · Affichages: 37

BOISGONTIER

XLDnaute Barbatruc
Repose en paix
Bonjour,

Code:
Sub RegroupeLigneCumul2()
  Set f1 = Sheets("BD")
  Tbl = f1.Range("A2:K" & f1.[A65000].End(xlUp).Row).Value
  Nlignes = UBound(Tbl)
  ncol = UBound(Tbl, 2)
  Dim TblRes(): ReDim TblRes(1 To UBound(Tbl), 1 To ncol)
  ligne = 1: lig = 1
  Do While ligne < Nlignes
    clé = Tbl(ligne, 7): temp = Tbl(ligne, 8)
    For col = 1 To 7: TblRes(lig, col) = Tbl(ligne, col): Next col
    Do While clé = Tbl(ligne, 7)
      clé2 = Tbl(ligne, 11)
      Do While clé = Tbl(ligne, 7) And clé2 = Tbl(ligne, 11)
         ligne = ligne + 1: If ligne >= Nlignes Then Exit Do
      Loop
      If ligne >= Nlignes Then Exit Do
      If clé = Tbl(ligne, 7) Then temp = temp + Tbl(ligne, 8)
    Loop
    TblRes(lig, 8) = temp
    lig = lig + 1
  Loop
  '---
  Set f2 = Sheets("résultats")
  f1.[a1].Resize(, ncol).Copy f2.[a1]
  f2.[a2].Resize(Nlignes, ncol) = TblRes
  f2.Activate
End Sub

Boisgontier
 

Pièces jointes

  • RegroupementSomme.xlsm
    85.2 KB · Affichages: 24

job75

XLDnaute Barbatruc
Bonjour ivan27, JB, le forum,

Une solution avec 2 Dictionary :
Code:
Private Sub Worksheet_Activate()
Dim ncolcopie, tablo, resu(), d1 As Object, d2 As Object, i&, x$, y$, n&, j%
ncolcopie = 8 'modifiable, au moibs 8
tablo = Feuil1.[A1].CurrentRegion.Resize(, 11).Offset(1) 'matrice, plus rapide
ReDim resu(1 To UBound(tablo), 1 To ncolcopie)
Set d1 = CreateObject("Scripting.Dictionary")
Set d2 = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(tablo) - 1
    x = tablo(i, 7): y = x & tablo(i, 11)
    If d1.exists(x) Then
        If Not d2.exists(y) Then resu(d1(x), 8) = resu(d1(x), 8) + tablo(i, 8)
    Else
        n = n + 1
        For j = 1 To ncolcopie: resu(n, j) = tablo(i, j): Next
        d1(x) = n 'mémorisation de la ligne
    End If
    d2(y) = ""
Next
If n Then [A2].Resize(n, ncolcopie) = resu 'restitution
Rows(n + 2 & ":" & Rows.Count).ClearContents 'RAZ en dessous
End Sub
Avantages par rapport à la solution de JB :

- il n'est pas nécessaire que le tableau source soit trié sur les colonnes G et K

- c'est un peu plus rapide (chez moi 25 millièmes de seconde contre 38 millièmes).

Edit : à l'avant-dernière ligne j'avais écrit Rows(n + 1... c'est bien sûr Rows(n + 2...

Bonne journée.
 

Pièces jointes

  • essai(1).xlsm
    88.9 KB · Affichages: 25
Dernière édition:

zebanx

XLDnaute Accro
Bonjour JB, JOB75, Ivan27

Merci à tous les deux pour ces codes :)
On a l'habitude d'additionner les items , c'est super intéressant de voir vos deux codes.

Suivant le classement effectué sur le tableau présenté par IVAN, je signale juste des écarts entre les deux tableaux du fait, il me semble, que le tableau de départ n'est pas trié sur l'ensemble des critères requis.
Cela concerne le code de JB.
Pour être direct, ci-joint le fichier avec un filtre sur une valeur qui pose problème, ce sera beaucoup plus clair de cette manière.

@+

Edit : l'ajout d'un tri colonne B puis K dans le tableau de départ résout le point évoqué. Le code reste une très belle copie et n'a pas besoin d'être modifié (àma) ou uniquement pour rajouter une ligne de "sort" qui évitera de perdre du temps à le modifier !;)
 

Pièces jointes

  • classeur_copy.xls
    225.5 KB · Affichages: 30
Dernière édition:

Discussions similaires

Statistiques des forums

Discussions
311 711
Messages
2 081 786
Membres
101 817
dernier inscrit
carvajal