Discussion :

[hedidev1]

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 !

[Marc-L]

Bonjour,

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

_________________________________________________________________________________________________________

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

_________________________________________________________________________________________________________

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

[MarcelG]

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.

[hedidev1]

Tres bien je regarde ca.

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

Merci

[hedidev1]

Ok marcel je regarde ca merci.

[MarcelG]

Salut,

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

[boisgontierjacques]

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 :

Sélectionner tout - Visualiser dans une fenêtre à part

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 :

Sélectionner tout - Visualiser dans une fenêtre à part

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

[hedidev1]

Bonjour,

merci Jacques, ça fonctionne bien.

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

Voici le code adapté :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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