(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é.

 

[Robert]

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

Bonsoir Lptht, bonsoir le forum,

Essaie comme ça avec la macro événementielle Change :

Private Sub Worksheet_Change(ByVal Target As Range)

'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)

If Target.Column <> 1 Then Exit Sub 'si le changement a lieu ailleurs que dans la colonne 1, sort de la procédure
If Target.Cells.Count > 1 Then Exit Sub 'si la sélection comporte plus d'une seule cellule, sort de la procédure
Set D = CreateObject("Scripting.Dictionary") 'définit le dictionnaire D
For Each CEL In Range("Mes_Objets") '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("D1").CurrentRegion 'définit la plage PL
Set PL = PL.Offset(0, 1).Resize(, PL.Columns.Count - 1) 'redéfinit la plage PL (sans la colonne C)
PL.Sort Key1:=Range("E1"), Order1:=xlAscending, Header:=xlYes 'tri la plage PL
Range(Cells(7, 4), Cells(Application.Rows.Count, 5)).Clear 'supprime les lignes en trop
End Sub

Merci Jacques BOISGONTIER...

Pour que le calcul soit automatique, voir la plage nommée Mes_Objets créée via le Gestionnaire de noms, à l'aide de la formule :

=DECALER(Feuil1!$A$2;;;NBVAL(Feuil1!$A:$A)-1)

 

[Lptht]

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

Merci Robert,

Cependant, le code ne renvoie pas les bons résultats. Je joins le fichier pour que vous puissiez le constater.
Par exemple, le code renvoie 2 "objet5" alors qu'il n'y en a qu'un et 29 "Objet4" alors qu'il n'y a même pas 29 cellules.

Je ne comprends vraiment rien.

De plus, serait-il possible que la macro s’exécut via un bouton et non un évènement sur la feuille?

 

[Robert]

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

Bonsoir Lptht, bonsoir le forum,

J'ai écrit le code en fonction de ton premier fichier exemple où il y avait en D1 : TOP5 objets et en E1 : Répétitions... Si tu enlève ces éléments le code ne fonctionne plus. De même, la formule que tu as écrite dans le Gestionnaire de noms n'est pas celle que je t'avais donnée. En revanche, je m'étais trompé dans l'ordre du tri mais tu as corrigé.
Si tu veux supprimer les étiquettes en D1:E1, il faudra adapter le code.

Rajoute une valeur en A12 et regarde ce que ça donne...

 

[Modeste geedee]

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

Bonsour®

Tableau croisé Dynamique ...

 

[Robert]

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

Bonsoir le fil, bonsoir le forum,

En relisant j'ai vu :

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.

et

De plus, serait-il possible que la macro s’exécut via un bouton et non un évènement sur la feuille?

Pas très logique tout ça...

 

[Lptht]

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

Bonjour Robert,

En effet je n'ai pas été très clair. Concrètement, je voulais que la macro s’exécute via un bouton et qu'on puisse ajouter des lignes sans avoir à modifier la macro. Après réflexion, "Range("A65536").End(xlUp).Row" convient parfaitement

par contre, concernant le code, je ne comprend pas la partie suivante:

Set PL = Range("D1").CurrentRegion 'définit la plage PL
Set PL = PL.Offset(0, 1).Resize(, PL.Columns.Count - 1) 'redéfinit la plage PL (sans la colonne C)
PL.Sort Key1:=Range("E1"), Order1:=xlDescending, Header:=xlYes 'tri la plage PL

En quoi si les étiquettes sont enlevées, le résultat n'est plus le bon?

 

[Staple1600]

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

Bonjour à tous

Lptht
Et la proposition de Modeste Geedee?
T'en penses quoi ?

Tu l'avais zappé ?

 

[Modeste geedee]

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

Bonsour®

Bonjour à tous
Lptht
Et la proposition de Modeste Geedee?
T'en penses quoi ?
Tu l'avais zappé ?

mais non... c'est toi qui a zappé le titre ....
il demande du VBA, on ne connait pas le B.A. BA. , alors on veut du sophistiqué !!!

Sub Macro3()
' brut de décoffrage via l'enregistreur
    Range("A2").Select
    ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:= _
        "Feuil1!R1C1:R40C1", Version:=xlPivotTableVersion12).CreatePivotTable _
        TableDestination:="Feuil1!R1C8", TableName:="Tableau croisé dynamique2", _
        DefaultVersion:=xlPivotTableVersion12
    Sheets("Feuil1").Select
    Cells(1, 8).Select
    With ActiveSheet.PivotTables("Tableau croisé dynamique2").PivotFields( _
        "Mes Objets")
        .Orientation = xlRowField
        .Position = 1
    End With
    ActiveSheet.PivotTables("Tableau croisé dynamique2").AddDataField ActiveSheet. _
        PivotTables("Tableau croisé dynamique2").PivotFields("Mes Objets"), _
        "Nombre de Mes Objets", xlCount
    Range("I2").Select
    ActiveSheet.PivotTables("Tableau croisé dynamique2").PivotFields("Mes Objets"). _
        AutoSort xlDescending, "Nombre de Mes Objets", ActiveSheet.PivotTables( _
        "Tableau croisé dynamique2").PivotColumnAxis.PivotLines(1), 1
    ActiveSheet.PivotTables("Tableau croisé dynamique2").PivotFields("Mes Objets"). _
        PivotFilters.Add Type:=xlTopCount, DataField:=ActiveSheet.PivotTables( _
        "Tableau croisé dynamique2").PivotFields("Nombre de Mes Objets"), Value1:=5
            With ActiveSheet.PivotTables("Tableau croisé dynamique2").PivotFields( _
        "Mes Objets")
        .Orientation = xlRowField
        .Position = 1
    End With

    Range("H7").Select
    ActiveSheet.PivotTables("Tableau croisé dynamique2").ColumnGrand = False
    Range("A1").Select
End Sub

 

[Robert]

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

Bonjour le fil, bonjour le forum,

MÔssieur Modeste Geedee (tu parles d'un Modeste !) je vous ai répondu ici.
Lptht, je regarderai quand je serai plus calme...

 

[Modeste geedee]

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

Bonsour®
j'ose espérer Robert, que ce post se veut sur le ton de l'humour... ( je n'ai pas remarqué de souriette )

J'admets que le mode épistolaire ne permet pas de toujours traduire de façon non-équivoque le ton et l'esprit de son émetteur ..

Cependant je suis interpelé par ton énumération des posts auxquels tu as participé et pour lesquels d'autres contributeurs ont émit des réponses différentes ou n'étant pas dans le droit fil de tes états d'âme...

Je ne pense pas, du moins je ne le souhaite pas que mes interventions soient empreintes d'invective ou de prosélytisme.

ne pas y chercher de sens autre que celui proposé en solution...
et garder une distance critique en regard de ce qui s'écarte du sujet... (aparté, élucubrations, ironie, intimité vis-à-vis des répondeurs)

 

[mapomme]

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

Bonjour à Lptht, au forum,

Je me fait minuscule pour proposer une autre p'tite version mais qui, tout comme celle de Robert et des autres, devrait faire la même chose:

Sub TopFive()
   Application.ScreenUpdating = False
   With ActiveSheet
      .Range("d2:e" & Rows.Count).ClearContents
      .Range("b:b").Insert
      With .Range("a2").Resize(.Range("a" & Rows.Count).End(xlUp).Row - 1, 2)
         .Columns("b:b") = 1
         .Range("e1").Consolidate Sources:=.Address(, , xlR1C1), Function:=xlSum, _
            TopRow:=False, LeftColumn:=True, CreateLinks:=False
      End With
      .Range("b:b").Delete
      With .Range("d2").Resize(.Range("e" & Rows.Count).End(xlUp).Row - 1, 2)
         .Sort key1:=.Columns(2), order1:=xlDescending, Header:=xlNo
      End With
      .Range("d7:e" & Rows.Count).ClearContents
   End With
   Application.ScreenUpdating = True
End Sub

nota: dans mon ennéagramme je possède,entre autres, le caractère médiateur, alors laissez moi en dehors de la polémique sinon je vais partir en vrille et glisser vers mon côté obscure .

 

[Robert]

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

Bonjour le fil, bonjour le forum,

Bonsour®
j'ose espérer Robert, que ce post se veut sur le ton de l'humour... blablabla...

Modeste, c'est à un prolo de base que tu t'adresses là. Je n'ai ni l'envie ni le temps de prendre un dictionnaire pour essayer de te comprendre. Mon vocabulaire est limité et souvent vulgaire. Je dis plus souvent couille que testicule et, bizarrement, même mon toubib comprend (oui bon d'accord j'avais choppé de morpions...).
Non il n'y avait pas d'humour ! Il y avait juste un coup de gueule contre cet humour avec ce ton pédant et condescendant (p... d'où j'ai sorti ce mot moi ?)...

Mais comme tu le dis : n'étant pas dans le droit fil de tes états d'âme... que j'ai traduis à Staple par : Je dois avoir mes ragnagnas (tu vois, toujours ce manque de classe qui me caractérise). Oublions...

 

[Modeste geedee]

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

Bonsour®

Oublions...

Oublions !!!

 

[mapomme]

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

Re,

Une version qui va au delà du top 5. On rajoute tous les suivants s'ils ont le même nombre d'apparitions que celui du top 5:

Sub TopFive()
   Dim i&
   Application.ScreenUpdating = False
   With ActiveSheet
      .Range("d2:e" & Rows.Count).ClearContents
      .Range("b:b").Insert
      With .Range("a2").Resize(.Range("a" & Rows.Count).End(xlUp).Row - 1, 2)
         .Columns("b:b") = 1
         .Range("e1").Consolidate Sources:=.Address(, , xlR1C1), Function:=xlSum, _
            TopRow:=False, LeftColumn:=True, CreateLinks:=False
      End With
      .Range("b:b").Delete
      With .Range("d2").Resize(.Range("e" & Rows.Count).End(xlUp).Row - 1, 2)
         .Sort key1:=.Columns(2), order1:=xlDescending, Header:=xlNo
      End With
      Do Until .Cells(7 + i, "e") <> .Cells(6, "e"): i = i + 1: Loop
      .Range("d" & (7 + i) & ":e" & Rows.Count).ClearContents
   End With
   Application.ScreenUpdating = True
End Sub