(VBA) Créer TOP5 des entités les plus répétées

[Lptht]

Bonsoir tout le monde,

Certain d'entre vous pourront peut-être m'aider à trouver un code VBA permettant, à partir d'une liste d'objet, de définir le TOP5 des objets qui reviennent le plus.

L'idéal serait d'avoir le top classé en ordre décroissant (n°1= le plus de répétitions, etc), avec à côté, le nombre d’occurrences pour chaque objet. Exemple: n°1: Objet3, 12 répétitions
Il y a aussi une contrainte sur le fait qu'on doit pouvoir ajouter des lignes à la liste. Le calcul du TOP se fait alors automatiquement et se met à jour.

Je ne sais pas par où commencer pour calculer le TOP5 des objets. Un grand merci d'avance à ceux qui prendront le temps de réfléchir à mon problème.

Vous trouverez le classeur "TOP5.xlsm" en pièce jointe pour plus de clarté.

 

[R@chid]

Re : (VBA) Créer TOP5 des entités les plus répétées

Bonjour @ tous,
C'est juste pour passer un salut aux amis, je sais qu'il n'a pas accepté la solution par TCD et il ne va pas accepter celle avec des formules
Voir PJ


@ + +

 

[Robert]

Re : (VBA) Créer TOP5 des entités les plus répétées

Bonjour le fil, bonjour le forum,

Bon ça y est, ils sont calmés ? Non mais c'est vrai quoi ! Est-ce que j'm'énerve moi ?...

Voici le code corrigé Lptht :

Sub top()

'Volé sur site de Jacques Boigontier : http://boisgontierjacques.free.fr/pages_site/Dictionnaire.htm

Dim D As Object 'déclare la variable D (Dictionnaire)
Dim CEL As Range 'déclare la variable CEL (CELlule)
Dim PL As Range 'déclare la variable PL (PLage)

Set D = CreateObject("Scripting.Dictionary") 'définit le dictionnaire D
For Each CEL In Range("A2:A" & Range("A65536").End(xlUp).Row) 'boucle sur toutes les cellules CEL de la plage nommée "Mes_Objets"
    D(CEL.Value) = D(CEL.Value) + 1 'alimente le dictionnaire D
Next CEL 'prochaine cellule de la boucle
Range("D2").Resize(D.Count, 1) = Application.Transpose(D.keys) 'récupère les noms
Range("E2").Resize(D.Count, 1) = Application.Transpose(D.items) 'récupère le nombre d'occurrence
Set PL = Range("D2").CurrentRegion 'définit la plage PL
PL.Sort Key1:=Range("E2"), Order1:=xlDescending, Header:=xlNo 'tri la plage PL
Range(Cells(7, 4), Cells(Application.Rows.Count, 5)).Clear 'supprime les lignes en trop
End Sub

La différence se trouve surtout dans la ligne de tri où, dans l'exemple précédent, j'utilisais la ligne 1 comme critère et je disais que les données avaient un en-tête. De plus, toujours dans l'exemple précédent , la colonne C comportait des numéros et la ligne Set PL=Range("D1").CurrentRegion sélectionnait aussi ces numéros. Comme je ne voulais pas les inclure dans le tri, j'étais obligé de les exclure de la plage PL avec :

Set PL = PL.Offset(0, 1).Resize(, PL.Columns.Count - 1) 'redéfinit la plage PL (sans la colonne C)

Maintenant tu n'en a plus besoin, la plage PL est définie par :
Set PL = Range("D2").CurrentRegion...

 

[Si...]

Re : (VBA) Créer TOP5 des entités les plus répétées

salut

Top ment 5 ? Que faire quand il y a des exæquos ?

pour pimenter la chose avec mon grain de sel : je* me vole avec un filtre sans doublon et une plage en tant que tableau :

Sub Pm()
  Dim L As Long
  Columns("D:E").Delete
  [Tb].AdvancedFilter Action:=2, CopyToRange:=[D1], Unique:=1
  [D1] = [A1]
  L = Range("D6500").End(xlUp).Row
  Range("E2:E" & L).FormulaLocal = "=NB.SI(A$2:A$37;D2)"
  Range("D2:E" & L).Sort [E2], 2
  Range("E2:E" & L) = Range("E2:E" & L).Value
End Sub

*pour les ignares comme moi qui n'utilisent pas le dico

Nota : c'est une procédure allégée de celle fournie par l'enregistreur de macro.

 

[Staple1600]

Re : (VBA) Créer TOP5 des entités les plus répétées

Bonjour à tous


Si...
Tu ne m'en voudras pas si j’ajoute des endives
Sub TheChiconsWay()
'variation sur une proc de Si...
Dim L As Long
Columns("D:E").Delete
[Tb].AdvancedFilter Action:=2, CopyToRange:=[D1], Unique:=1
[D1] = [A1]
L = Range("D6500").End(xlUp).Row
With Range("E2:E" & L)
.FormulaLocal = "=NB.SI(A$2:A$37;D2)"
Range("D2:E" & L).Sort [E2], 2
.value = .Value
end with
End Sub

PS: j'ai pas testé, mais j'ai mon fagot d'ortie sur ma table de chevet au cas ou

Robert
En cas de plages discontinues, CurrentRegion pourrait te jouer des tours.

 

[Robert]

Re : (VBA) Créer TOP5 des entités les plus répétées

Bonjour le fil, bonjour le forum,

Woaw Lptht ! Tu as la totale là : Macros, TCD, Formules...

 

[job75]

Re : (VBA) Créer TOP5 des entités les plus répétées

Bonjour à tous,

Dans le fichier joint, une solution semblable à celle présentée par Robert mais avec des tableaux VBA.

Placer tout ceci dans le code de la feuille :

Private Sub CommandButton1_Click()
Top5
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, [A:A]) Is Nothing Then Top5
End Sub

Sub Top5()
Dim t, d As Object, i&, x, a, b, c()
t = Range("A2", Range("A" & Rows.Count).End(xlUp)(3)) 'au moins 2 éléments
Set d = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(t)
  x = t(i, 1)
  If x <> "" Then d(x) = d(x) + 1
Next
If d.Count Then
  '---transposition (au cas où il y a plus de 65536 éléments)---
  a = d.keys: b = d.items
  ReDim c(UBound(a), 1)
  For i = 0 To UBound(a)
    c(i, 0) = a(i): c(i, 1) = b(i)
  Next
  '---restitution et classement---
  Application.ScreenUpdating = False
  [D2].Resize(d.Count, 2) = c
  [D:E].Sort [E1], xlDescending, Header:=xlYes 'tri
End If
Range("D" & IIf(d.Count < 5, d.Count + 2, 7) & ":E" & Rows.Count).ClearContents
End Sub

L'exécution est rapide même sur un très grand tableau.

Noter que je n'utilise pas Application.Transpose car cette fonction n'accepte pas plus de 65536 éléments.

Edit : sur Win XP - Excel 2003 j'ai testé sur 65000 lignes.

L'exécution prend 3,75 secondes dont 2,95 secondes pour la seule instruction [D2].Resize(d.Count, 2) = c

A+

 

[job75]

Re : (VBA) Créer TOP5 des entités les plus répétées

Bonjour le fil, le forum,

Pour éviter la restitution de tout le tableau dans la feuille on peut exécuter un tri VBA :

Private Sub CommandButton1_Click()
Top5
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, [A:A]) Is Nothing Then Top5
End Sub

Sub Top5()
Dim t, d As Object, i&, x, a, b
t = Range("A2", Range("A" & Rows.Count).End(xlUp)(3)) 'au moins 2 éléments
Set d = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(t)
  x = t(i, 1)
  If x <> "" Then d(x) = d(x) + 1
Next
If d.Count Then
  '---tri VBA---
  a = d.keys: b = d.items
  Call tri(a, b, 0, UBound(a))
  '---restitution---
  For i = 0 To IIf(UBound(a) < 4, UBound(a), 4)
    [D2].Offset(i) = a(i): [E2].Offset(i) = b(i)
  Next
End If
If d.Count < 5 Then Range("D" & d.Count + 2 & ":E6").ClearContents
End Sub

Sub tri(a, b, gauc, droi)         ' Quick sort
Dim ref, g, d, temp
ref = b((gauc + droi) \ 2)
g = gauc: d = droi
Do
    Do While b(g) > ref: g = g + 1: Loop
    Do While ref > b(d): d = d - 1: Loop
    If g <= d Then
      temp = a(g): a(g) = a(d): a(d) = temp
      temp = b(g): b(g) = b(d): b(d) = temp
      g = g + 1: d = d - 1
    End If
Loop While g <= d
If g < droi Then Call tri(a, b, g, droi)
If gauc < d Then Call tri(a, b, gauc, d)
End Sub

Fichier (2).

Testé sur le même tableau de 65000 lignes, le code est un peu plus rapide : 1,84 seconde.

A+