Comptage des doublons

erics83

XLDnaute Impliqué
Bonjour,

J'essaye d'utiliser le code de BOISGONTIER "Fonction sansDoublons2col()" qui fonctionne magnifiquement bien....

Une petite question : comment compter le nombre de doublons ? dans l'exemple en ligne "F" comment compter le nombre de fois où "Dupont jean" apparait, je passe par une formule type "sommeprod", mais je pense qu'il y a plus rapide.....(surtout que j'ai un fichier de 10000 lignes et que sommeprod prend un peu de temps.....

En vous remerciant par avance,
 

erics83

XLDnaute Impliqué
Merci job75

Sorry pour l'erreur. ...c'était la colonne F. ...lol

Par contre, c'est pour tous les nom prénom que je souhaitais le nombre de doublons (c'était juste pour l'exemple)
Et sans passer par des formules dans les cellules, je pensais que comme on avait une matrice définie, on pourrait passer par un calcul via VBA. ...A moins que ce soit pas possible auquel cas je passerai par soomeprod ou nb.si...
Mais il me semble étonnant qu'on ne puisse pas le faire directement via une boucle VBA...d'ou ma demande d'aide...
Merci pour votre aide,
 

job75

XLDnaute Barbatruc
Re,

Vous pouvez par exemple exécuter cette macro :
Code:
Sub Doublons()
Dim t, d As Object, i&, a, b, mes$
t = Intersect(ActiveSheet.[F:G], ActiveSheet.UsedRange.EntireRow) 'au moins 2 éléments
Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = vbTextCompare 'la casse est ignorée
For i = 1 To UBound(t)
  If t(i, 1) <> "" Then d(t(i, 1)) = d(t(i, 1)) + 1 'comptage
Next
If d.Count = 0 Then Exit Sub 'sécurité,liste vide
'---suppression si le compte égale 1---
a = d.keys: b = d.items
For i = 0 To UBound(a)
  If b(i) = 1 Then d.Remove a(i)
Next
If d.Count = 0 Then MsgBox "Pas de doublon", , "Doublons": Exit Sub
'---liste finale---
a = d.keys: b = d.items
For i = 0 To UBound(a)
  mes = mes & vbLf & a(i) & " (" & b(i) & ")"
Next
MsgBox Mid(mes, 2), , "Doublons"
End Sub
On pourrait facilement trier la liste, soit sur les valeurs (a) soit sur le nombre de doublons (b).

Bonne fin de soirée.
 

job75

XLDnaute Barbatruc
Re,

Si la base de donnée est mal fichue il peut y avoir des espaces superflus.

Il est facile de les éliminer mais c'est moins rapide :
Code:
Sub Doublons()
Dim t, d As Object, i&, x$, a, b, mes$
t = Intersect(ActiveSheet.[F:G], ActiveSheet.UsedRange.EntireRow) 'au moins 2 éléments
Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = vbTextCompare 'la casse est ignorée
For i = 1 To UBound(t)
  x = Application.Trim(t(i, 1)) 'SUPPRESPACE
  If x <> "" Then d(x) = d(x) + 1 'comptage
Next
If d.Count = 0 Then Exit Sub 'sécurité,liste vide
'---suppression si le compte égale 1---
a = d.keys: b = d.items
For i = 0 To UBound(a)
  If b(i) = 1 Then d.Remove a(i)
Next
If d.Count = 0 Then MsgBox "Pas de doublon", , "Doublons": Exit Sub
'---liste finale---
a = d.keys: b = d.items
For i = 0 To UBound(a)
  mes = mes & vbLf & a(i) & " (" & b(i) & ")"
Next
MsgBox Mid(mes, 2), , "Doublons"
End Sub
A+
 

erics83

XLDnaute Impliqué
Bonjour Job75,

Merci pour ce code, très utile et parfait !!!

j'ai essayé de l'adapter au fichier et le comptage se fait bien, néanmoins prenons le cas "Dupont" : votre code compte 3 "Dupont", alors qu'il y a 2 Dupont Yann et 1 Dupont Brigitte, et c'est cela que je recherche, un comptage prenant en compte les 2 colonnes.

Merci pour votre aide,
 

Pièces jointes

  • SansDoublons2Col.xls
    38.5 KB · Affichages: 36

erics83

XLDnaute Impliqué
Bonjour Job75,

Je viens de voir qu'effectivement, je m'étais mal expliqué.... en fait je pars du fichier de BOISGONTIER, fais tourner la macro et ce que je souhaiterai, c'est qu'en colonne F apparaissent le nombre de fois que l'on a un doublon, dans l'exemple : F2 : 2, F3 : 1, F4 : 2, F5 :1, etc......
Donc D:E est l'analyse de A:B et liste les doublons et ce que je souhaiterai c'est le comptage par doublon.

(mon fichier fait 10000 lignes et 50 colonnes, là c'est juste pour l'exemple....)

En vous remerciant pour votre aide,
 

job75

XLDnaute Barbatruc
Re,

Bon je suppose que les tableaux sont traités séparément.

La macro dans le code de la feuille (clic droit sur l'onglet et Visualiser le code) :
Code:
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim t, d As Object, i&, x$, y$, z$, a, b, mes$
If Target <> "Nom" Then Exit Sub
Cancel = True
t = Intersect(Target.Resize(, 2).EntireColumn, Me.UsedRange.EntireRow)
Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = vbTextCompare 'la casse est ignorée
For i = 1 To UBound(t)
  x = Application.Trim(t(i, 1)) 'SUPPRESPACE
  y = Application.Trim(t(i, 2)) 'SUPPRESPACE
  z = x & Chr(1) & y
  If x & y <> "" Then d(z) = d(z) + 1 'comptage
Next
'---suppression si le compte égale 1---
a = d.keys: b = d.items
For i = 0 To UBound(a)
  If b(i) = 1 Then d.Remove a(i)
Next
If d.Count = 0 Then MsgBox "Pas de doublon", , "Doublons": Exit Sub
'---liste finale---
a = d.keys: b = d.items
For i = 0 To UBound(a)
  mes = mes & vbLf & a(i) & " (" & b(i) & ")"
Next
MsgBox Replace(Mid(mes, 2), Chr(1), " "), , "Doublons"
End Sub
Je concatène avec Chr(1) pour distinguer les cas (très rares) :

- Nom : Dupont Martin, Prénom : Pierre

- Nom : Dupont, Prénoms : Martin Pierre.

Fichier joint.

A+
 

Pièces jointes

  • SansDoublons2Col(1).xls
    82 KB · Affichages: 34

erics83

XLDnaute Impliqué
Merci Job75,

Nos post se sont croisés....j'ai essayé de reprendre votre code pour essayer d'obtenir le résultat voulu :
Code:
Sub job()

Dim t, d As Object, i&, x$, y$, z$, a, b, mes$



t = [A2:N10000] ' Intersect(Target.Resize(, 2).EntireColumn, Me.UsedRange.EntireRow)
Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = vbTextCompare 'la casse est ignorée
For i = 1 To UBound(t)
  x = Application.Trim(t(i, 1)) 'SUPPRESPACE
  y = Application.Trim(t(i, 2)) 'SUPPRESPACE
  z = x & Chr(1) & y
  If x & y <> "" Then d(z) = d(z) + 1 'comptage
Next
'---suppression si le compte égale 1---
a = d.keys: b = d.items
'For i = 0 To UBound(a)
' If b(i) = 1 Then d.Remove a(i)
'Next
If d.Count = 0 Then MsgBox "Pas de doublon", , "Doublons": Exit Sub
'---liste finale---
a = d.keys: b = d.items


For i = 0 To UBound(a)
' mes = vbLf & a(i) & " (" & b(i) & ")"
  tot = tot + 1
  'Cells(i + 1, 10) = vbLf '& a(i) '& " (" & b(i) & ")" 'mes
  Cells(i + 1, 11) = a(i)
  Cells(i + 1, 12) = b(i)

Next

'MsgBox Replace(Mid(mes, 2), Chr(1), " "), , "Doublons"
End Sub
(là je fais apparaitre en colonne K......

Et tout fonctionne, mon adaptation du code n'est pas très orthodoxe, mais cela fonctionne....

Merci pour votre aide Job75
A+ pour de prochaines aventures.....



En vous remerciant pour votre aide,
 
Dernière édition:

job75

XLDnaute Barbatruc
Re,

Nos posts se sont croisés.

On arrive enfin à comprendre ce que vous voulez, ce n'est pas trop tôt :
Code:
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim t, d As Object, i&, x$, y$, z$
If Target.Address <> "$A$1" Then Exit Sub
Cancel = True
t = Intersect(Target.Resize(, 2).EntireColumn, Me.UsedRange.EntireRow)
Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = vbTextCompare 'la casse est ignorée
For i = 1 To UBound(t)
  x = Application.Trim(t(i, 1)) 'SUPPRESPACE
  y = Application.Trim(t(i, 2)) 'SUPPRESPACE
  z = x & Chr(1) & y
  If x & y <> "" Then d(z) = d(z) + 1 'comptage
Next
If d.Count = 0 Then Exit Sub 'sécurité, tableau vide
'---restitution et conversion des données---
Application.ScreenUpdating = False
With [D1].Resize(d.Count) 'D1 à adapter
  .Resize(, 3).EntireColumn = Empty 'RAZ
  .Value = Application.Transpose(d.keys)
  .TextToColumns .Cells(1), xlDelimited, Space:=False, Other:=True, OtherChar:=Chr(1) 'commande Convertir
  .Offset(, 2) = Application.Transpose(d.items)
  .Cells(1, 3) = "Nombre"
  .Resize(, 3).Sort .Cells(1), xlAscending, , .Cells(1, 2), xlAscending, Header:=xlYes 'tri
End With
End Sub
Fichier (2).

A+
 

Pièces jointes

  • SansDoublons2Col(2).xls
    82.5 KB · Affichages: 40

erics83

XLDnaute Impliqué
Merci Job75,
C'est vrai que j'aurai dû être plus clair dans mon premier post, mais à force de faire des essais, j'ai un peu fait évolué ce que je désirai....
Merci pour ce code qui correspond parfaitement à ce que je recherchais. Merci

A+ pour de prochaines aventures....;)
 

laetitia90

XLDnaute Barbatruc
bonjour toutes :):) & tous:):)

une version sans application transpose peut être interessant sur trés gros fichier
VB:
Sub es()
Dim t(), i As Long, m As Object, x As Long
   Application.ScreenUpdating = 0
   Set m = CreateObject("Scripting.Dictionary")
   m.CompareMode = vbTextCompare
   t = Range("a2:c" & Cells(Rows.Count, 1).End(3).Row)
   For i = 1 To UBound(t)
   t(i, 3) = 1
   If m.Exists(t(i, 1) & t(i, 2)) Then
    t(m(t(i, 1) & t(i, 2)), 3) = t(m(t(i, 1) & t(i, 2)), 3) + 1
    Else
    x = x + 1
    t(x, 1) = t(i, 1): t(x, 2) = t(i, 2): m(t(i, 1) & t(i, 2)) = x
    End If
    Next i
   [d2].Resize(x, 3) = t
End Sub
 

Discussions similaires

Réponses
11
Affichages
449