compter sans doublon

[I folima Elda]

Bonjour à tous,

Voilà, j'aurai besoin d'un coup de main afin de perfectionner une macro. J'ai chercher sur le forum mais les réponse ne m'ont pas beaucoup convaincu.
En effet, j'ai une liste qui contient plusieurs terme
exple:

pomme
pomme
banane
poire
banane
pomme
orange
poire
poire
banane​

Comme vous pouvez le voir cette liste comporte plusieurs fois certains termes, comme "pomme"
J'utilise donc une macro afin de compter chacun de ces termes

Sub Test()
For x = 16 To 30
a = Cells(x, 2)
'If Cells(x, 1) = "type" Then
'GoTo retour
'Else
y = y + (a & " * " & Application.WorksheetFunction.CountIf(Range("B16:B30"), a)) & Chr(13)
'End If
'retour:
Next
MsgBox (y)
End Sub

Cependant il va me répéter à chaque fois qu'il y a 3*pomme à chaque mots "pomme" et ainsi pour chacun des fruits du genre:

pomme * 3
pomme * 3
banane * 3
poire * 3
banane * 3
pomme * 3
orange * 1
poire * 3
poire * 3
banane * 3​

La question est donc: est-il possible d'éviter de lui faire faire des répétitions inutiles? En gros je voudrais qu'il m'indique ceci

pomme * 3
banane * 3
poire * 3
orange * 1​

Merci de votre aide, et je continue à chercher dans mon coin
I folima Elda

 

[Brigitte]

Re : compter sans doublon

Bonsoir,

Tu veux vraiment une macro ?

Car avec sommeprod ou nb.si, tu pourrais aussi compter tes occurrences.

 

[Cousinhub]

Re : compter sans doublon

Bonsoir,

Bonsoir, Brigitte

par macro :

Sub Doublon()
Dim Doublons As Object
Dim Cel As Range, Plage As Range
Dim I As Integer
Dim Temp
Set Doublons = CreateObject("Scripting.Dictionary")
Set Plage = Range("B16:B30")
For Each Cel In Plage
    If Cel <> "" Then Doublons.Item(Cel.Value) = Cel.Value
Next Cel
Temp = Application.Transpose(Doublons.items)
For I = LBound(Temp) To UBound(Temp)
    y = y & Temp(I, 1) & " * " & Application.CountIf(Plage, Temp(I, 1)) & Chr(13)
Next I
MsgBox y
End Sub

 

[BOISGONTIER]

Re : compter sans doublon

Bonsoir,

Sub Essai5()
  Set mondico = CreateObject("Scripting.Dictionary")
  For Each c In Range("a2", [a65000].End(xlUp))
    mondico.Item(c.Value) = mondico.Item(c.Value) + 1
  Next c
  For Each c In mondico.keys
    temp = temp & c & "*" & mondico.Item(c) & vbLf
  Next c
  MsgBox temp
End Sub


Sub Essai4()
  Set mondico = CreateObject("Scripting.Dictionary")
  For Each c In Range("a2", [a65000].End(xlUp))
     mondico.Item(c.Value) = c.Value & " *  " & Val(Right(mondico(c.Value), 3)) + 1
  Next c
  [j2].Resize(mondico.Count, 1) = Application.Transpose(mondico.items)
End Sub

Sub Essai1()
  Set mondico = CreateObject("Scripting.Dictionary")
  For Each c In Range("a2", [a65000].End(xlUp))
    mondico.Item(c.Value) = mondico.Item(c.Value) + 1
  Next c
  [E2].Resize(mondico.Count, 1) = Application.Transpose(mondico.keys)
  [F2].Resize(mondico.Count, 1) = Application.Transpose(mondico.items)
End Sub

Sub Essai2()
  Set mondico = CreateObject("Scripting.Dictionary")
  For Each c In Range("a2", [a65000].End(xlUp))
    mondico.Item(c.Value) = mondico.Item(c.Value) + 1
  Next c
  a = mondico.keys
  b = mondico.items
  For i = LBound(a) To UBound(a)
    Cells(i + 2, 8) = a(i) & "*" & b(i)
  Next i
End Sub

Sub Essai3()
  Set mondico = CreateObject("Scripting.Dictionary")
  For Each c In Range("a2", [a65000].End(xlUp))
    mondico.Item(c.Value) = mondico.Item(c.Value) + 1
  Next c
  i = 2
  For Each c In mondico.keys
    Cells(i, 9) = c & "*" & mondico.Item(c)
    i = i + 1
  Next c
End Sub

JB
http://boisgontierjacques.free.fr

 

[I folima Elda]

Re : compter sans doublon

bhbh, j'ai testé ton code et il fonctionne parfaitement merci. Mais je vais faire mon p'tit chieur. Tu pourrais m'expliquer comment il fonctione? Car j'aime pas utiliser quelque chose sans comprendre et là :s

Mais merci de la réponse, vous êtes génial ^^