Suppression doublons et addition

Nanir · 21 Juin 2006

Bonjour le forum,

Il y a beaucoup de fils au sujet des doublons et j'ai réussi à trouver assez rapidement un petit code les supprimer dans une colonne.

Seulement dans mon cas c'est un peu plus compliqué et je n'arrive pas à trouver mon bonheur malgré mes recherches.

Voici un exemple de ce que j'aimerai faire.

admettons :
Colonne A - Colonne B
a - 1000
a - 200
b - 2000
C - 1200
C - 300
D - 2100

J'aimerai obtenir :
Colonne A - Colonne B
a - 1200
b - 2000
C - 1500
D - 2100

On peut très bien avoir ce résultat via un tableau croisé dynamique seulement j'aimerai pouvoir le faire par VBA. Est ce possible?

Merci d'avance pour votre aide,
Cordialement.

Hervé · 21 Juin 2006

Bonjour nannir

une syntaxe possible parmis d'autres :

Sub Bouton1_QuandClic()
Dim data As New Collection
Dim tablo()
Dim c As Range
Dim i As Integer
Dim plage1 As Range
Dim plage2 As Range

Set plage1 = Range('a1:a' & Range('a65536').End(xlUp).Row)
Set plage2 = Range('b1:b' & Range('b65536').End(xlUp).Row)

On Error Resume Next
For Each c In plage1
data.Add c, CStr(c)
Next c
On Error GoTo 0

ReDim tablo(1 To data.Count, 1 To 2)

For i = 1 To data.Count
tablo(i, 1) = data(i)
tablo(i, 2) = Application.SumIf(plage1, data(i), plage2)
Next i

Range('c1').Resize(UBound(tablo, 1), 2) = tablo
End Sub

renvoi en c1

salut

sousou · 21 Juin 2006

bonjour nanir et hervé

Il est vraie que c'est difficile de répondre sans pouvoir joindre de fichiers. Je ne sais pas ce qui c'est passé, Pourquoi cette situation?
Si quelqu'un peux m'expliquer, je suis preneur.

Enfiin essai ce code et adapte le
Sub deb()

For Each i In Selection

lettre = Left(i, 1)
If Left(i.Offset(1, 0), 1) = lettre Then
première = Right(i, Len(i) - 4)
deuxième = Right(i.Offset(1, 0), Len(i.Offset(1, 0)) - 4)
données = Val(première) + Val(deuxième)
i.Value = lettre & ' - ' & données
MsgBox i.Offset(1, 0).Rows
i.Offset(1, 0).Rows.EntireRow.Delete
Else
End If
Next
End Sub

Nanir · 21 Juin 2006

C'est génial Hervé!

J'ai modifié la dernière ligne afin d'obtenir le renvoie sur la feuille 2 en A1. Ca me permet de vraiment voir la différence avec les deux tableaux,

Merci beaucoup pour ta rapidité et ton efficacité, ca me fais gagné un temps fou!

A+

pierrejean · 21 Juin 2006

bonjour à tous et toutes

ma version (du style de celle d'Hervé mais en plus rustique)

Code:

Option Explicit
Sub addition()
Dim m As Integer
Dim n As Integer
Dim ligne As Integer
Dim total As Integer
total = 0
ligne = 1
Dim col As Collection
Set col = New Collection
For n = 1 To Sheets('Feuil1').Range('A65536').End(xlUp).Row
On Error Resume Next
col.Add Sheets('Feuil1').Range('A' & n), CStr(Sheets('Feuil1').Range('A' & n))
On Error GoTo 0
Next n
For n = 1 To col.Count
 For m = 1 To Sheets('Feuil1').Range('A65536').End(xlUp).Row
   If Sheets('Feuil1').Range('A' & m) = col(n) Then
     total = total + Sheets('Feuil1').Range('B' & m)
   End If
 Next m
Sheets('Feuil1').Range('D' & ligne) = col(n)
Sheets('Feuil1').Range('E' & ligne) = total
total = 0
ligne = ligne + 1
Next n
End Sub

resultats en D et E

Nanir · 21 Juin 2006

Merci à tous pour vos réponses.

Effectivement sans fichier exemple il est difficile de trouver une solution et je me rends compte que j'ai mal formulé mon problème même s'il y a un bon début.

En fait j'ai un tableau de A1:J1522

En A j'ai des matricules. Dans cette colonne je doit supprimer les doublons.
En J J'ai des montant que je dois additionner.
Mais entre A et J j'ai des infos qui ne doivent pas disparaitre (noms, prénoms...)

Pouvez vous m'aider,
Merci.

Hervé · 21 Juin 2006

re

alors comme ceci, peut etre :

Sub Bouton1_QuandClic()
Dim data As New Collection
Dim tablo
Dim tablores()
Dim c As Range
Dim i As Integer, j As Integer
Dim k As Byte
Dim plage1 As Range
Dim plage2 As Range

Set plage1 = Range('a1:a' & Range('a65536').End(xlUp).Row)
Set plage2 = Range('j1:j' & Range('j65536').End(xlUp).Row)
tablo = Range('a1:j' & Range('j65536').End(xlUp).Row)

On Error Resume Next
For Each c In plage1
data.Add c, CStr(c)
Next c
On Error GoTo 0

ReDim tablores(1 To data.Count, 1 To 9)

For i = 1 To data.Count
tablores(i, 1) = data(i)
For j = 1 To UBound(tablo)
If tablo(j, 1) = tablores(i, 1) Then
For k = 2 To 8
tablores(i, k) = tablo(j, k)
Next k
End If
Next j
tablores(i, 9) = Application.SumIf(plage1, data(i), plage2)
Next i

Sheets(2).Range('a1').Resize(UBound(tablores, 1), 9) = tablores
End Sub

salut

pierrejean · 21 Juin 2006

re

toujours le meilleur Hervé

ma version quand même

Code:

Dim ligne As Integer
Dim total As Integer
total = 0
ligne = 1
Dim col As Collection
Set col = New Collection
For n = 1 To Sheets('Feuil1').Range('A65536').End(xlUp).Row
On Error Resume Next
col.Add Sheets('Feuil1').Range('A' & n), CStr(Sheets('Feuil1').Range('A' & n))
On Error GoTo 0
Next n
For n = 1 To col.Count
 For m = 1 To Sheets('Feuil1').Range('A65536').End(xlUp).Row
   If Sheets('Feuil1').Range('A' & m) = col(n) Then
     total = total + Sheets('Feuil1').Range('J' & m)
   End If
 Next m

Sheets('Feuil2').Range('A' & ligne) = col(n)
Sheets('Feuil2').Range('J' & ligne) = total
total = 0
ligne = ligne + 1
Next n
ligne = 1
For n = 1 To col.Count
   For m = 1 To Sheets('Feuil1').Range('A65536').End(xlUp).Row
   If Sheets('Feuil1').Range('A' & m) = col(n) Then
      Sheets('Feuil1').Range('B' & m & ':I' & m).Copy Destination:=Sheets('Feuil2').Range('B' & ligne & ':I' & ligne)
      ligne = ligne + 1
      Exit For
   End If
   Next m
Next n

End Sub

Nanir · 21 Juin 2006

c'est impeccable, irréprochable, vraiment.
C'est pil poil ce que je voulais.

Merci infiniement!

Nanir · 22 Juin 2006

Re le fil,

Puis je vous demander un dernier petit service?

Pourriez vous me rajouter les commentaires avec vos codes?

En fait, j'aimerai comprendre et apprendre ce que vous avez fait. L'idéal serait qu'à therme j'arrive à le refaire seul, surtout si je dois adapter le code dans un autre tableaux.

J'ai franchement envie de progresser et votre traduction va pouvoir m'aider.

Amicalement,

pierrejean · 22 Juin 2006

re Nanir

en esperant etre comprehensible !!
(si souci ne pas hesiter à revenir)

Code:

Option Explicit
Sub addition()
Dim m As Integer
Dim n As Integer
Dim ligne As Integer
Dim total As Integer
total = 0
'initialisation de ligne (ou l'on ecrira)
ligne = 1
'création d'une collection
Dim col As Collection
Set col = New Collection
'une collection (avec une clé) est un tableau qui necomporte pas de doublons
For n = 1 To Sheets('Feuil1').Range('A65536').End(xlUp).Row
On Error Resume Next 'permet d'eviter le bug au moment ou la collection refuse le doublon
'la clé est habituellement contituée par Cstr(item)
col.Add Sheets('Feuil1').Range('A' & n), CStr(Sheets('Feuil1').Range('A' & n))
'le goto 0 réinitialise la gestion d'erreur !! INDISPENSABLE
On Error GoTo 0
Next n
'on exploite la collection
'pour chaque membre on cherche dans la colonne A et on totalise la valeur de la colonne B
For n = 1 To col.Count
 For m = 1 To Sheets('Feuil1').Range('A65536').End(xlUp).Row
   If Sheets('Feuil1').Range('A' & m) = col(n) Then
     total = total + Sheets('Feuil1').Range('J' & m)
   End If
 Next m
'apres examen de toute la colonne A on ecrit les resultats en feuil2
Sheets('Feuil2').Range('A' & ligne) = col(n)
Sheets('Feuil2').Range('J' & ligne) = total
'réinitialisation du total et increment de la ligne pour ecriture suivante
total = 0
ligne = ligne + 1
Next n
' on reprend les valeurs entre la colonne A et la colonne J
ligne = 1
' pour chaque valeur de la collection
For n = 1 To col.Count
'lecture de la colonne A
   For m = 1 To Sheets('Feuil1').Range('A65536').End(xlUp).Row
   'des que l'on trouve l'equivalence
   If Sheets('Feuil1').Range('A' & m) = col(n) Then
   'on copie en feuil2 on incremente la ligne et on sort
      Sheets('Feuil1').Range('B' & m & ':I' & m).Copy Destination:=Sheets('Feuil2').Range('B' & ligne & ':I' & ligne)
      ligne = ligne + 1
      Exit For
   End If
   Next m
Next n

End Sub

Nanir · 22 Juin 2006

Merci Pierrejean,

Grâce à tes indications et l'aide de VBA je vais essayer de bien comprendre le code,

Cordialement,

Nanir · 22 Juin 2006

Pierrejean,

Juste pour info, j'ai modifié une ligne de ton code, car en l'état il y a une imcompatibilité de type.

Ce n'est pas ta faute mais plutot la mienne.
En effet dans mon exemple en colonne J j'ai donné des nombres entiers. Il s'agit en fait de nombres décimaux.

Du coup, et j'espère avoir bien fait (en tout cas ca fonctionne) :

Dim total As Integer
total = 0

devient

Dim total as variant

Nanir.

pierrejean · 22 Juin 2006

re Nanir

Bravo

tu es sur la bonne voie

puisqu'il s'agit de nombres tu pourrais utiliser

Dim total as Double

mais Variant convient egalement

en ce qui me concerne je vais essayer de piger le code de Hervé ( je suis a peu près sur d'y trouver des pepites !!!)

Hervé · 22 Juin 2006

bonjour à vous deux

y'a pas beaucoup de pépites dans ce code pierrejean 🙂

quelques commentaires :

Sub Bouton1_QuandClic()
Dim data As New Collection
Dim tablo
Dim tablores()
Dim c As Range
Dim i As Integer, j As Integer
Dim k As Byte
Dim plage1 As Range
Dim plage2 As Range

'crée une variable (plage1) objet(set) contenant la plage A1:a...
Set plage1 = Range('a1:a' & Range('a65536').End(xlUp).Row)
'crée une variable (plage2) objet(set) contenant la plage j1:a...
Set plage2 = Range('j1:j' & Range('j65536').End(xlUp).Row)
'stock dans un tableau variant l'ensemble des données
tablo = Range('a1:j' & Range('j65536').End(xlUp).Row)

'utilisation d'une collection pour extraire sans doublons

'on error resume next, annule les erreurs provoquées par des clées doublons
On Error Resume Next
'pour chaque cellule (c) de la plage1
For Each c In plage1
'ajoute (add) à la collection (data) l'item (c), et la clé (cstr(c))
data.Add c, CStr(c)
'cellule suivante
Next c
'réinitialise le gestionnaire d'erreur
On Error GoTo 0

'prépare un tableau dynamique (tablores)
'en le dimmensionnant pour x lignes (1 to data.count) et 9 colonnes (1 to 9)
ReDim tablores(1 To data.Count, 1 To 9)

'boucle sur chaque élément de la collection data
For i = 1 To data.Count
'remplit la premiere colonne de la ligne i de tablores avec
'l'element i de la collection (data(i))
tablores(i, 1) = data(i)
'boucle sur chaque ligne du tableau de stock des données (tablo)
'de la ligne 1 jusqu'à la limite supérieur du tableau
For j = 1 To UBound(tablo)
'si la premiere colonne de la ligne i du tableau de stockage est
'egale à la valeur de la premiere colonne du tableau de resultat
'j'aurais pu faire aussi : if tablo(j,i)=data(i)
If tablo(j, 1) = tablores(i, 1) Then
'boucle sur les 8 colonne du tablo de stockage
For k = 2 To 8
'et alimente les 8 colonnes du tableau de résultat
tablores(i, k) = tablo(j, k)
Next k
End If
Next j
'ici c'est la somme
'j'utilise simplement la syntaxe vba de la formule somme.si
'somme.si(plage,critere,plageàsommer)
'somme.si(range('a1:ax),criteres,range('j1:jx')
'et je stocke le résultat dans la derniere colonne du tableau résultat
tablores(i, 9) = Application.SumIf(plage1, data(i), plage2)
Next i
'renvoi en feuille 2 à partir de A1 le tableau de résultat
Sheets(2).Range('a1').Resize(UBound(tablores, 1), 9) = tablores
End Sub

je reviens

salut

Suppression doublons et addition

Nanir

XLDnaute Occasionnel

Hervé

XLDnaute Barbatruc

sousou

XLDnaute Barbatruc

Nanir

XLDnaute Occasionnel

pierrejean

XLDnaute Barbatruc

Nanir

XLDnaute Occasionnel

Hervé

XLDnaute Barbatruc

pierrejean

XLDnaute Barbatruc

Nanir

XLDnaute Occasionnel

Nanir

XLDnaute Occasionnel

pierrejean

XLDnaute Barbatruc

Nanir

XLDnaute Occasionnel

Nanir

XLDnaute Occasionnel

pierrejean

XLDnaute Barbatruc

Hervé

XLDnaute Barbatruc

Discussions similaires

Suppression doublons et addition

XLDnaute Occasionnel

XLDnaute Barbatruc

XLDnaute Barbatruc

XLDnaute Occasionnel

XLDnaute Barbatruc

XLDnaute Occasionnel

XLDnaute Barbatruc

XLDnaute Barbatruc

XLDnaute Occasionnel

XLDnaute Occasionnel

XLDnaute Barbatruc

XLDnaute Occasionnel

XLDnaute Occasionnel

XLDnaute Barbatruc

XLDnaute Barbatruc

Discussions similaires

Privacy & Transparency

Privacy & Transparency