Compter doublons pour chaque valeur dans array

Bonjour,

j'ai cherché du coté des dictionnaires mais pas trouvé la solution.

Je met dans un array des valeurs (500.000) et je souhaite compter les doublons, donc mettre dans la 2eme dimensions ou dans un autre tableau (sans changer l'ordre car je colle après dans la feuille excel) le nombre de doublons pour chaque valeur.

Exemple:

t(1)=a
t(2)=b
t(3)=a
t(4)=c
t(5)=c

Donnera:

d(1)=2
d(2)=1
d(3)=2
d(4)=2
d(5)=2


Merci !

Bonjour,

pas besoin de code pour ce résultat, utiliser la fonction de feuille de calculs NB.SI !

_________________________________________________________________________________________________________

Merci de cliquer sur :plusser: pour chaque message ayant aidé puis sur :resolu: pour clore cette discussion …

_________________________________________________________________________________________________________

Je suis Paris, Istanbul, Berlin, Nice, Bruxelles, Charlie, …

Bonjour à toi, Bonjour au Forum,

BONNE ANNEE A TOUS! SANTE, JOIES ET ACCOMPLISSEMENT.

Pour ma part, je ne vois que l'exploitation d'un dictionnaire.
Schéma:
- Alimentation d'un dictionnaire à partir de l'Array
- Comptabiliser chaque clé du dictionnaire dans l'Array

Au demeurant, j'admettrais volontiers l'existence d'une solution plus simple.

Essaie de coder ainsi et reviens si nécessaire en retournant ton code.

Tres bien je regarde ca.

Ca marche si les données sont sur plusieurs feuilles ?

Merci

Ok marcel je regarde ca merci.

Salut,

Oui, du fait que tu redimensionnes ton Array en préservant les données.
Et ce quelle qu'en soit l'origine.

Bonsoir,

Pour un grand nombre d'items, doit être + rapide que NBSI:

-Pour 10.000 items, le temps de calcul n'est pas mesurable avec la fonction matricielle NBSIMAT().
-Avec NB.SI() classique recopié 10.000 fois, il faut 3 sec de calcul.

Code:

---

1 2 3 4 5 6 7 8 9 10 11 12 13

Sub essai() t = [A2:A6] Set d1 = CreateObject("Scripting.Dictionary") For Each c In t d1(c) = d1(c) + 1 Next c Dim t2(): ReDim t2(1 To UBound(t)) For i = 1 To UBound(t) t2(i) = d1(t(i, 1)) Next i [b2].Resize(UBound(t)) = Application.Transpose(t2) End Sub

---

On peut construire un fonction perso matricielle

sélectionner B2:B6
=NBSIMAT(A2:A6)
Valider avec maj+ctrl+entrée

Code:

---

1 2 3 4 5 6 7 8 9 10 11 12 13

Function NBSIMAT(champ) t = champ Set d1 = CreateObject("Scripting.Dictionary") For Each c In t d1(c) = d1(c) + 1 Next c Dim t2(): ReDim t2(1 To UBound(t)) For i = 1 To UBound(t) t2(i) = d1(t(i, 1)) Next i NBSIMAT = Application.Transpose(t2) End Function

---

http://boisgontierjacques.free.fr/fi...s/NBSIDico.xls

boisgontier
http://boisgontierjacques.free.fr

Bonjour,

merci Jacques, ça fonctionne bien.

PS: j'utilise souvent votre site (très bien) :)

Voici le code adapté :

Code:

---

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44

lUbndDoubl = 0 lId = 1 For Each ws In wbHist.Sheets If ws.Name Like "####*" Then lId = 1 For i = 2 To lGetSheetLastLine(ws, 1, 1) ReDim Preserve sTabDoubl(1 To lId + lUbndDoubl) sTabDoubl(lId + lUbndDoubl) = ws.Cells(i, 30).Value lId = lId + 1   Next i lUbndDoubl = UBound(sTabDoubl) End If Next ws   ReDim sTabDoubl2(1 To UBound(sTabDoubl), 1 To 1) For i = 1 To UBound(sTabDoubl) sTabDoubl2(i, 1) = sTabDoubl(i) Next i   Set d1 = CreateObject("Scripting.Dictionary") For Each c In sTabDoubl2 d1(c) = d1(c) + 1 Next c Dim t2(): ReDim t2(1 To UBound(t), 1 To 1) For i = 1 To UBound(t) t2(i, 1) = d1(sTabDoubl2(i, 1)) Next i   s = 1 For Each ws In wbHist.Sheets If ws.Name Like "####*" Then Erase tr ReDim tr(1 To lGetSheetLastLine(ws, 1, 1) - 1, 1 To 1) For i = s To lGetSheetLastLine(ws, 1, 1) - 2 + s tr(i - s + 1, 1) = t2(i, 1) Next i ws.Range(ws.Cells(2, 31), ws.Cells(lGetSheetLastLine(ws, 1, 1), 31)).Value = tr s = lGetSheetLastLine(ws, 1, 1) End If Next ws   Erase t2 Erase tr

---