Réaliser un classement VBA

Version imprimable

22/06/2018, 10h47
nosnoz

Réaliser un classement VBA

Bonjour à tous !

Je suis actuellement confronté à un problème. Pour décrire mon fichier Excel, celui-ci contient deux colonnes : une avec des catégories de produit ( la même catégorie peut revenir plusieurs fois ), et une autre avec le montant dépensé par une personne dans cette catégorie de produits. Je souhaite réaliser deux classements :

Dans un premier temps il me faudrait le classement des catégories de produits revenant le plus souvent dans le fichier.
Dans un second temps, il me faudrait le classement des catégories de produits en fonction du montant total dépensé dans cette catégorie. La difficulté vient du fait que les catégories reviennent plusieurs fois dans la même colonne, il faut donc sommer le montant pour chaque catégorie et renvoyer le classement.

Tout ceci doit être codé en VBA, étant donné que cette analyse devra être réalisée pour plusieurs clients je veux juste avoir à relancer le code.

J'ai fait des recherches sur ce sujet sur internet, cependant je n'ai pas compris le peu que j'ai trouvé...
Si quelqu'un pouvait me donner un coup de main je lui en serais très reconnaissant !

Bonjour Nosnoz, bonjour le forum,

Ce qui serait bien c'est, qu'a défaut d'un fichier exemple, tu nous dises dans quelle colonnes se trouvent les données. Ça nous permettrait de recréer ton environnement pour pouvoir tester la macro avant de t'envoyer une proposition... Le code ci-dessous fonctionne si les données se trouvent en colonne A et B. Les classements sont fait dans les colonnes D/E et G/H :

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
45
46
47
48
49
50
51
52
53
54
55
56
57
Sub Macro1()
Dim O As Worksheet
Dim TV As Variant
Dim D As Object
Dim TMP As Variant
Dim I As Integer
Dim TT() As Variant
 
Set O = Worksheets("Feuil1")
O.Range("D1").CurrentRegion.Clear
O.Range("G1").CurrentRegion.Clear
TV = O.Range("A1").CurrentRegion
Set D = CreateObject("Scripting.Dictionary")
For I = 2 To UBound(TV)
    D(TV(I, 1)) = D(TV(I, 1)) + 1
Next I
TMP = D.keys
ReDim TT(0 To UBound(TMP), 1 To 2)
For j = 0 To UBound(TMP)
    T = 0
    For I = 2 To UBound(TV, 1)
        If TV(I, 1) = TMP(j) Then
            TT(j, 1) = TMP(j)
            TT(j, 2) = TT(j, 2) + TV(I, 2)
        End If
    Next I
Next j
O.Range("D1").Value = "Produit"
O.Range("E1").Value = "Occurrence"
O.Range("D2").Resize(D.Count, 1) = Application.Transpose(D.keys)
O.Range("E2").Resize(D.Count, 1) = Application.Transpose(D.items)
ActiveWorkbook.Worksheets("Feuil1").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Feuil1").Sort.SortFields.Add Key:=Range("E:E"), _
    SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Feuil1").Sort
    .SetRange O.Range("D1").CurrentRegion
    .Header = xlYes
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
End With
O.Range("G1").Value = "Produit"
O.Range("H1").Value = "Dépense"
O.Range("G2").Resize(D.Count, 2).Value = TT
ActiveWorkbook.Worksheets("Feuil1").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Feuil1").Sort.SortFields.Add Key:=Range("H:H"), _
    SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Feuil1").Sort
    .SetRange O.Range("G1").CurrentRegion
    .Header = xlYes
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
End With
End Sub

22/06/2018, 12h13
nosnoz

1 pièce(s) jointe(s)

Tout d'abord merci pour ta réponse.

J'ai essayé le programme que tu m'as envoyé mais au moment de l'exécuter je reçois une erreur d'exécution 6 : dépassement de capacité.
Mes données se trouvent bien dans les colonnes A et B, je t'envoie un fichier exemple pour que tu vois à quoi il ressemble.
22/06/2018, 13h26
MarcelG

Salut,

Regarde ta déclaration de variables.
Tutoriel fondamental
Les variables par Silkyroad/
22/06/2018, 13h36
MarcelG

A Thautem,

En évoquant la déclaration de variables, je pense que trop souvent l'on voit des dictionnaires mal déclarés (Variant,...)
Mieux vaut les déclarer comme tel

Code:

Dim D as Scripting.Dictionary

Au préalable, activer la référence

Code:

Microsoft Scripting Runtime

Ce processus a le grand avantage de disposer de toutes les propriétés et méthodes des dictionnaires lors d'une saisie semi automatique du code.
22/06/2018, 14h54
Thautheme

Bonjour le fil, bonjour le forum,

@Marcel Merci du tuyau !...
@Nosnoz, remplace Dim I As Integer par Dim I As Long.

Bonjour nosnoz,Marcel et Robert,

Robert heureux de te revoir!

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
Sub test()
With CreateObject("Adodb.connection")
    .Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ThisWorkbook.FullName & ";Extended Properties=""Excel 12.0;HDR=YES;"""
    ThisWorkbook.Sheets("Feuil2").Range("A2").CopyFromRecordset .Execute("select [categorie],count([categorie]) from [Feuil1$] group by [categorie] order by count([categorie]) desc")
     ThisWorkbook.Sheets("Feuil3").Range("A2").CopyFromRecordset .Execute("select [categorie],sum([montant]) from [Feuil1$] group by [categorie] order by sum([montant]) desc")
 
ActiveWorkbook.Worksheets("Feuil1").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Feuil1").Sort.SortFields.Add Key:= _ 
Application.transpose(.Execute("select. [categorie] from (select [categorie],sum([montant]) from [Feuil1$] group by [categorie] order by sum([montant]) desc)").getrows)
 
, _
    SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
 
    .Close
End With
End Sub

22/06/2018, 16h41
nosnoz

Mon problème est résolu, merci à vous tous pour votre aide :)
22/06/2018, 16h48
Invité

Penses à ceux qui pourraient rencontrer le même problème !