Macro pour regrouper des doublons

S

Spacepak

XLDnaute Junior
Bonjour à tous,

je dispose de deux tableaux dans lesquels figurent des nom de clients, des types de comptes associés et le montant pour chaque comptes. Le tableau 1 est pour le 1 er trimestre et le 2ème pour le 2 ème trimestre.

J'aimerai pouvoir réaliser une macro qui me permettrait d'additionner les montants pour un même type de compte pour un même client.

Je vous ai écris en rouge dans le tableau à droite ce que j'aimerai obtenir avec cette macro.

Pourriez vous m'aider?
 

Pièces jointes

  • Exemple.xlsx
    10.1 KB · Affichages: 60
  • Exemple.xlsx
    10.1 KB · Affichages: 63
  • Exemple.xlsx
    10.1 KB · Affichages: 65
Trier par date Trier par votes
S

Spacepak

XLDnaute Junior
Re : Macro pour regrouper des doublons

Le premier concerne juste le premier trimestre et le 2 eme tableau le 2 eme trimestre mais il n'y a pas de date.

Le calcul doit se faire tous les 2 trimestres. Et donc tous les deux trimestres les valeurs des tableaux changent.
 
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Re : Macro pour regrouper des doublons

Bonjour à tous,

Une macro très rapide car elle utilise l'objet Dictionary et des tableaux VBA :

Code: 
Sub Somme()
Dim t1, t2, tablo(), d As Object, i&, x$, a, b, s
t1 = Range("B5:D" & [B65536].End(xlUp).Row).Value2
t2 = Range("G5:I" & [G65536].End(xlUp).Row).Value2
ReDim tablo(1 To UBound(t1) + UBound(t2), 1 To 3)
Set d = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(t1)
  x = t1(i, 1) & Chr(1) & t1(i, 2)
  If d.exists(x) Then
    d(x) = d(x) + t1(i, 3)
  Else
    d.Add x, t1(i, 3)
  End If
Next
For i = 1 To UBound(t2)
  x = t2(i, 1) & Chr(1) & t2(i, 2)
  If d.exists(x) Then
    d(x) = d(x) + t2(i, 3)
  Else
    d.Add x, t2(i, 3)
  End If
Next
a = d.keys: b = d.items
For i = 1 To d.Count
  s = Split(a(i - 1), Chr(1))
  tablo(i, 1) = s(0)
  tablo(i, 2) = s(1)
  tablo(i, 3) = b(i - 1)
Next
[K5:M5].Resize(d.Count) = tablo
Range("K" & 5 + d.Count & ":M" & Rows.Count).ClearContents
End Sub
Il est très facile de l'adapter s'il y a plus de 2 trimestres.

Fichier joint.

Edit : ajouté la dernière ligne (effacement).

A+
 

Pièces jointes

  • Exemple(1).xls
    48 KB · Affichages: 53
  • Exemple(1).xls
    48 KB · Affichages: 58
  • Exemple(1).xls
    48 KB · Affichages: 63
Dernière édition:
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Re : Macro pour regrouper des doublons

Bonjour le fil, le forum,

Je reviens ici car il est intéressant de montrer l'utilisation d'un tableau de tableaux :

Code: 
Sub Somme()
Dim t1, t2, d As Object, t, h&, i&, x$, tablo()
t1 = Range("B5:D" & [B65536].End(xlUp).Row).Value2
t2 = Range("G5:I" & [G65536].End(xlUp).Row).Value2
Set d = CreateObject("Scripting.Dictionary")
For Each t In Array(t1, t2) 'tableau de tableaux
  h = h + UBound(t)
  For i = 1 To UBound(t)
    x = t(i, 1) & Chr(1) & t(i, 2)
    If d.exists(x) Then
      d(x) = d(x) + t(i, 3)
    Else
      d.Add x, t(i, 3)
    End If
  Next
Next
ReDim tablo(1 To h, 1 To 3)
t1 = d.keys: t2 = d.items
For i = 1 To d.Count
  t = Split(t1(i - 1), Chr(1))
  tablo(i, 1) = t(0)
  tablo(i, 2) = t(1)
  tablo(i, 3) = t2(i - 1)
Next
[K5:M5].Resize(d.Count) = tablo
Range("K" & 5 + d.Count & ":M" & Rows.Count).ClearContents
End Sub
Fichier (2).

Edit : j'ai supprimé les variables a b s, économie oblige.

A+
 

Pièces jointes

  • Exemple(2).xls
    43 KB · Affichages: 52
  • Exemple(2).xls
    43 KB · Affichages: 47
  • Exemple(2).xls
    43 KB · Affichages: 49
Dernière édition:
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Re : Macro pour regrouper des doublons

Re,

Autre manière, un peu plus simple, d'utiliser l'objet Dictionary :

Code: 
Sub Somme()
Dim t1, t2, d As Object, t, h&, i&, x$, tablo()
t1 = Range("B5:D" & [B65536].End(xlUp).Row).Value2
t2 = Range("G5:I" & [G65536].End(xlUp).Row).Value2
Set d = CreateObject("Scripting.Dictionary")
For Each t In Array(t1, t2) 'tableau de tableaux
  h = h + UBound(t)
  For i = 1 To UBound(t)
    x = t(i, 1) & Chr(1) & t(i, 2)
    d(x) = d(x) + t(i, 3)
  Next
Next
ReDim tablo(1 To h, 1 To 3)
t1 = d.keys: t2 = d.items
For i = 1 To d.Count
  t = Split(t1(i - 1), Chr(1))
  tablo(i, 1) = t(0)
  tablo(i, 2) = t(1)
  tablo(i, 3) = t2(i - 1)
Next
[K5:M5].Resize(d.Count) = tablo
Range("K" & 5 + d.Count & ":M" & Rows.Count).ClearContents
End Sub
Fichier (3).

A+
 

Pièces jointes

  • Exemple(3).xls
    46 KB · Affichages: 50
  • Exemple(3).xls
    46 KB · Affichages: 53
  • Exemple(3).xls
    46 KB · Affichages: 54
Vote positif 0 Vote négatif
Efgé

Efgé

XLDnaute Barbatruc
Re : Macro pour regrouper des doublons

Bonjour à tous, Bonjour job75 :) , Pour le fun, on peux aussi se passer de tableaux temporaires, on gagne 1/100 em de seconde sur deux fois 4 000 lignes.... Cordialement
 

Pièces jointes

  • Exemple(4).xls
    42.5 KB · Affichages: 63
  • Exemple(4).xls
    42.5 KB · Affichages: 63
  • Exemple(4).xls
    42.5 KB · Affichages: 58
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Re : Macro pour regrouper des doublons

Re, salut Efgé :)

Et merci pour tes bonnes remarques, j'en tire tout à fait profit (économie de 2 tableaux).

Par MP Spacepak m'a demandé une 4ème colonne avec la moyenne des doublons.

J'utilise donc un 2ème objet Dictionary pour compter les doublons :

Code: 
Sub Somme()
Dim t1, t2, d As Object, d1 As Object, t, i&, x$, tablo()
t1 = Range("B5:D" & [B65536].End(xlUp).Row).Value2
t2 = Range("G5:I" & [G65536].End(xlUp).Row).Value2
Set d = CreateObject("Scripting.Dictionary")
Set d1 = CreateObject("Scripting.Dictionary")
For Each t In Array(t1, t2)
  For i = 1 To UBound(t)
    x = t(i, 1) & Chr(1) & t(i, 2)
    d(x) = d(x) + t(i, 3)
    d1(x) = d1(x) + 1 'compte les doublons
  Next
Next
ReDim tablo(d.Count - 1, 3)
i = 0
For Each t In d.keys
  t1 = Split(t, Chr(1))
  tablo(i, 0) = t1(0)
  tablo(i, 1) = t1(1)
  tablo(i, 2) = d(t)
  tablo(i, 3) = d(t) / d1(t) 'moyenne
  i = i + 1
Next
[K5:N5].Resize(d.Count) = tablo
Range("K" & 5 + d.Count & ":N" & Rows.Count).ClearContents
End Sub
Fichier (5).

A+
 

Pièces jointes

  • Exemple(5).xls
    47.5 KB · Affichages: 63
  • Exemple(5).xls
    47.5 KB · Affichages: 72
  • Exemple(5).xls
    47.5 KB · Affichages: 72
Vote positif 0 Vote négatif
L

laetitia90

XLDnaute Barbatruc
Re : Macro pour regrouper des doublons

bonjour tous :):):):):)

en prenant les derniers code avant calcul moyenne
a mon humble avis si on cherche la vitesse d'execution on gagne pas beaucoup de temps qu'on redim 2 ou 3 colonnes

sur une grande plage de données dans le cas present le code de l'ami Efgé:) moins rapide que le code de l'ami job:)
-25 %
ou on gagne du temps dans la séquence SPLIT a mon avis
Code: 
t1 = d.keys: t2 = d.Items
For i = 1 To d.Count
  t = Split(t1(i - 1), Chr(1))
  tablo(i, 1) = t(0)
  tablo(i, 2) = t(1)
  tablo(i, 3) = t2(i - 1)
Next

plus rapide que ........ci-dessous

Code: 
i = 0
For Each c In d.keys
  s = Split(c, Chr(1))
  For J = 0 To 1
    tablo(i, J) = s(J)
  Next J
  tablo(i, 2) = d(c)
  i = i + 1
Next c

normal 2 boucles!!!!

ps: je viens de tester sur 30000 lignes confirme.....:)

autremenent pour la vitesse pure utiliser directement Dictionary

Set m = New Dictionary

Dim m As Dictionary

mais neccesite activer reférence microsoft Scripting Runtime
 
Dernière édition:
Vote positif 0 Vote négatif
Efgé

Efgé

XLDnaute Barbatruc
Re : Macro pour regrouper des doublons

Re à tous, Bonsoir laetitia :)
En effet, je pense que ma seconde boucle, que je ne prenais que pour une "fioriture", s'avère être une mauvaise idée.
La passe
VB: 
For J = 0 To 1
    tablo(i, J) = s(J)
  Next J
  tablo(i, 2) = d(c)
Détruit le gain de
VB: 
For Each c In d.keys
Donc la meilleure solution serait entre les deux
VB: 
Sub Somme()
Dim t1, t2, d As Object, t, i&, x$, tablo(), s, C
t1 = Range("B5:D" & [B65536].End(xlUp).Row)
t2 = Range("G5:I" & [G65536].End(xlUp).Row)
Set d = CreateObject("Scripting.Dictionary")
For Each t In Array(t1, t2) 'tableau de tableaux
  For i = 1 To UBound(t)
    x = t(i, 1) & Chr(1) & t(i, 2)
    d(x) = d(x) + t(i, 3)
  Next i
Next t
ReDim tablo(d.Count, 2)
i = 0
For Each C In d.keys
  s = Split(C, Chr(1))
  tablo(i, 0) = s(0)
  tablo(i, 1) = s(1)
  tablo(i, 2) = d(C)
  i = i + 1
Next C
Range(Cells(5, 11), Cells(5, 11).End(4)(1, 3)).ClearContents
Cells(5, 11).Resize(UBound(tablo, 1), UBound(tablo, 2) + 1) = tablo
End Sub
A vérifier, comme d'habitude avec moi :D

Cordialement
 
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Re : Macro pour regrouper des doublons

Bonjour le fil, le forum,

De toute façon comme déjà dit les durées des calculs sont brèves.

Testé sur Win7/Excel 2010, en recopiant le 1er trimestre sur 56000 lignes :

- sans la moyenne (1 Dictionary) => 0,28 seconde

- avec la moyenne (2 Dictionary) => 0,36 seconde

A+
 
Vote positif 0 Vote négatif

Discussions similaires

M
  • Question
Microsoft 365 Construction d'un tableau selon 2 critères en VBA
Réponses
6
Affichages
214
merinos
merinos
M
  • Résolu(e)
Microsoft 365 Formules pour tableaux
Réponses
4
Affichages
195
Marvin57
M
M
  • Question
Microsoft 365 Somme.Si en enlevant les doublons
Réponses
3
Affichages
134
DJunqueira
D
S
  • Question
Microsoft 365 Valeur cible pour trouver un poucentage
Réponses
11
Affichages
362
saggigo
S
R
  • Résolu(e)
XL 2021 Transformer des données
Réponses
4
Affichages
184
Richard30
R
Q
  • Question
Microsoft 365 Créer un formulaire pour duplication d'onglet avec tableau
Réponses
6
Affichages
200
job75
job75
D
  • Question
Microsoft 365 Cas réel - avec problème complexe sur de la prevision de match en evitant les doublons
Réponses
1
Affichages
291
Dock91
D
P
  • Résolu(e)
Microsoft 365 Crée un VBA pour repérer des doublons sur un tableur excel
2 3
Réponses
31
Affichages
2 K
patrick965
P
I
  • Question
Microsoft 365 Formule pour doublon avec rechercheV
Réponses
1
Affichages
350
JHA
J
G
  • Question
Microsoft 365 Mayday - Tableau récapitulatif
2 3
Réponses
39
Affichages
2 K
geoffroych
G

Membres actuellement en ligne

12 membres et 330 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
312 198
Messages
2 086 143
Membres
103 129
dernier inscrit
Atruc81500