identifier et lister les 5 premiers d'une base de donnée

[erics83]

Bonjour,

J'ai un classeur, avec des onglets par mois. Il s'agit d'entreprises avec qui il y a eu 1 contact. Elles ont une famille d'activité et dépendent d'une agence (=lieux). Je cherche à sortir, par famille d'activité, les 5 premières entreprises et les lister avec le nombre de fois où elles sont citées. De même, je cherche à connaitre, par famille le nombre d'entreprises citées par agence.
J'ai utilisé le tuto de JB pour compter le nombre d'occurence des entreprises, c'est très rapide, par contre après, ne sachant pas comment refaire un Dictionary (car je pense que c'est ce qu'il y a de plus rapide...ou un Tbl..ou autre...), j'ai mis des formules pour identifier les familles des entreprises comptées, j'ai repris sous forme de colonne chaque famille et classé en utilisant RANG, puis j'ai essayé d'identifier via INDEX/EQUIV, les 5 premiers....Cela fonctionne, certes, mais ce n'est pas très rapide...et surtout pas très VBA.....lol.
De même, pour le comptage par famille et agence, j'ai utilisé SOMMEPROD, qui n'est pas très rapide non plus...
Et puis, je compile en copiant/collant les résultats par mois dans des onglets spécifiques (="Tot").

Cela ne me donne pas finalement le résultat escompté, car RANG donne le même classement si ex-æquo et donc ne recopie pas le nom de l'entreprise...(cf famille F1 et classement N°4). De même, le code utilisé compte l'ensemble des entreprises, je souhaiterai avoir un classement des 5 premiers par agence....

Je suis persuadé que l'on pourrait aller beaucoup plus rapidement et simplement que de passer par des formules...mais j'ai besoin de votre aide.....et s'il faut mettre l'ensemble des données dans 1 seul onglet (=on compile les mois), cela ne me dérange pas...l'essentiel étant que je puisse avoir les 5 premiers par mois et par agence et par famille et que j'ai un tableau de comptage des familles par agence....

je sais que cela est possible via les TCD, mais le fichier initial fait 195 Mo et donc très long à charger, je cherche donc à compiler les infos, ensuite, je copirai/collerai les onglets "Tot" dans un nouveau classeur et utiliserai des TCD. (j'ai essayé de faire des TCD en lien extérieur avec cette base de donnée, mais le poids du classeur reste le même, d'où la recherche de compilation...), et ce fichier sera certainement moins lourd...

Je mets un fichier test en PJ, pour plus de clareté....
En vous remerciant par avance,

merci pour votre aide

 

[Bebere]

bonsoir
eric une 1ère partie

Public Sub PartDAEQ()
    Dim a, b, i As Long, j As Long, l As Long, c As Long
    Feuil1.[DB2:EQ6] = ""
    a = Feuil1.[DA2:EQ6]
    b = Feuil1.Range("AK2:CX" & Feuil1.Range("AL65536").End(xlUp).Row)    'pour recherche
    c = 6
    For j = 2 To UBound(a, 2) Step 2
        For i = 1 To UBound(a, 1)
            For l = 1 To UBound(b, 1)
                If b(l, c) = a(i, 1) Then    '1 à 5
                    a(i, j) = b(l, c - 2)
                    a(i, j + 1) = b(l, c - 1)
                    Exit For
                End If
            Next l
        Next i
        c = c + 3
    Next j
    Feuil1.[DA2].Resize(UBound(a, 1), UBound(a, 2)) = a
End Sub

 

[erics83]

Bonjour et merci Bebere,

Merci pour ce code, qui effectivement remet bien en DA le classement, évitant la formule RANG. Par contre, il rencontre le même problème que moi : prenons l'exemple de F1 :

en 3ème position ex-aequo : E225 et E495. et donc le code met E225 en 3ème position et vide en 4ème....comme la formule RANG, et c'est "normal" puisqu'il cherche '4' et ne "trouve" pas....

Merci pour votre aide,

 

[Bebere]

bonjour
Eric bien je vais voir ce que je peux
ce ne sera pas pour tout de suite
voilà un code pour l'autre partie

Dim a, famille, lieu ', MonDico As Object

Sub PartEUFI()
    Dim a, i As Long, l As Long, li As Long, c As Long
    a = Feuil1.[EU2:FI23]
    famille = Feuil1.Range("Z2", Feuil1.[Z65000].End(xlUp))
    lieu = Feuil1.Range("AF2", Feuil1.[AF65000].End(xlUp))

    For j = 2 To UBound(a, 2)
        For i = 2 To UBound(a, 1)
            a(i, j) = CompteItems(CStr(a(i, 1)), CStr(a(1, j)))
        Next i
    Next j

    Feuil1.[EU2].Resize(UBound(a, 1), UBound(a, 2)) = a
End Sub

Function CompteItems(x As String, y As String) As Long
Dim i As Long
   
        For i = 1 To UBound(famille, 1)
    If famille(i, 1) = x And lieu(i, 1) = y Then CompteItems = CompteItems + 1
    Next i
   
End Function

 

[erics83]

Super merci Bebere,

Le code évitant les SOMMEPROD fonctionne parfaitement !!! en plus, j'en ai compris la logique....lol

Reste le problème du classement....
Merci,
Merci pour votre aide,

 

[Bebere]

bonjour
Eric avec ce code tu auras les 5 premiers en colonne DA
temps :environ 10 secondes

Sub RechercheEtabFamille()
    Dim a, i As Long, DicoFamille As New Dictionary, DicoEtabFam As New Dictionary

    a = Feuil1.Range("T2:Z" & Feuil1.Range("T65536").End(xlUp).Row)
   
    For i = 1 To UBound(a)
        DicoFamille(a(i, 1)) = a(i, 1)
    Next
    For Each Item In DicoFamille.Items
        For i = 1 To UBound(a)
            If a(i, 1) = Item Then
                DicoEtabFam(a(i, 1) & "-" & a(i, 7)) = DicoEtabFam(a(i, 1) & "-" & a(i, 7)) + 1
            End If
        Next
    Next
    a = DicoEtabFam.Items
    QuickSortDes a, LBound(a), UBound(a)
    For i = LBound(a) To 4 '5 1ers
        Feuil1.Range("DA" & i + 2) = a(i)
    Next
End Sub

Sub QuickSortDes(ByRef av As Variant, ByVal iBeg As Long, ByVal iEnd As Long)
' from http://www.vba-programmer.com/Snippe...rt_Single.html
    Dim iLo As Long
    Dim iHi As Long
    Dim Temp As Variant
    Dim vSep As Variant

    iLo = iBeg
    iHi = iEnd
    vSep = av((iBeg + iEnd) / 2)

    Do
        Do While av(iLo) > vSep    ' descending
            iLo = iLo + 1
        Loop

        Do While av(iHi) < vSep    ' descending
            iHi = iHi - 1
        Loop

        If iLo <= iHi Then
            Temp = av(iLo)
            av(iLo) = av(iHi)
            av(iHi) = Temp
            iLo = iLo + 1
            iHi = iHi - 1
        End If
    Loop While iLo <= iHi

    If iBeg < iHi Then QuickSortDes av, iBeg, iHi
    If iLo < iEnd Then QuickSortDes av, iLo, iEnd
End Sub

 

[erics83]

Super merci Bebere,

Donc, il me suffit de "compiler" les 4 codes (JB + les 3 votre) et j'obtiens le résultat attendu. Merci !!!

En fait, je me me posais la question : je suis passé par les différentes colonnes (AD etc...) pour obtenir un classement, et vous m'avez donné les codes évitant et/ou étant plus rapides que mes formules, mais je vois que vous avez utilisé Dictionary et Tbl, donc ma question est :
Est -il possible d'avoir, à partir de A:AI, d'avoir le résultat qui s'afficherait en AK des 5 premiers par famille ? (=ce que vous avez mis en DA) ? = sans "passer" par la "vision" de AN:CX (qui était surtout là pour trouver les classements ?)

Mais vos codes me suffisent largement déjà, c'était juste pour essayer d'optimiser la séquence de calcul et d'affichage...

En vous remerciant pour votre aide,

 

[Bebere]

Eric pas vu celui là,avec ta remarque bien
en plus résultat code JB
tu veux de l'aide ou tu essayes de te débrouiller

 

[erics83]

Merci Bebere,

Disons qu'avec tes codes, j'ai mon résultat attendu, je me demandais juste, puisqu'on met tout dans des dictionary et Tbl, je me disais qu'on pouvait éviter d'afficher AN:VX, et donner directement les résultats...mais c'est juste pour savoir si c'est possible....et donc, j'aurai besoin d'aide, car les Tbl et Dictionary, c'est pas mon fort...mais j'essaye de comprendre....lol

Merci pour ton aide,

 

[Bebere]

bonjour
Eric nouveau code à mettre dans un module
commencer par début.Si tu n'as pas besoin de AK:AL il y a moyen de faire autrement
le code peut servir pour toutes les feuilles(commentaire dans début)
le code précédent ne donnait pas le même résultat

Option Explicit
Public Ws As Worksheet, a, famille, lieu, Tbl, i As Long, DicoEtabFam As Dictionary

Sub debut()
    Set Ws = Feuil1    'activesheet si tu as un bouton dans chaque feuille
    Tbl = Ws.Range("T2:AF" & Ws.Range("T65536").End(xlUp).Row)
    CompteEtab
    PartEUFI
    PartDAEQ
End Sub

Sub CompteEtab()
    Dim MonDico As New Dictionary    ', c As Range
'  Set MonDico = CreateObject("Scripting.Dictionary")
    For i = 1 To UBound(Tbl)
        MonDico(Tbl(i, 1)) = MonDico(Tbl(i, 1)) + 1    'Etab
    Next i
    Ws.[ak2].Resize(MonDico.Count, 1) = Application.Transpose(MonDico.keys)
    Ws.[al2].Resize(MonDico.Count, 1) = Application.Transpose(MonDico.items)
    Ws.[al1].Sort Key1:=Ws.[al2], Order1:=xlDescending, Header:=xlYes
End Sub

Sub PartEUFI()
    Dim a, i As Long, j As Long
    a = Ws.[EU2:FI23]
    For j = 2 To UBound(a, 2)
        For i = 2 To UBound(a, 1)
            a(i, j) = CompteItems(CStr(a(i, 1)), CStr(a(1, j)))
        Next i
    Next j
    Ws.[EU2].Resize(UBound(a, 1), UBound(a, 2)) = a
End Sub

Public Sub PartDAEQ()
    Dim a, b, i As Long, j As Long, l As Long, li As Long, c As Long
    Ws.[DB2:EQ6] = ""
    a = Ws.[DB1:EQ6]
    b = Ws.Range("AK2:AK6")    '5 etab pour recherche
    i = 1
    For li = 1 To UBound(b)
        If i < 6 Then i = i + 1
        For j = 1 To UBound(a, 2) Step 2
            a(i, j) = b(li, 1) 'famille
            a(i, j + 1) = CompteEtabFamille(CStr(b(li, 1)), CStr(a(1, j)))
        Next j
    Next li
    Ws.[DB1].Resize(UBound(a, 1), UBound(a, 2)) = a
End Sub

Function CompteItems(x As String, y As String) As Long
    Dim i As Long

    For i = 1 To UBound(Tbl, 1)
        'si etab=x et famille=y alors compte
        If Tbl(i, 7) = x And Tbl(i, 13) = y Then CompteItems = CompteItems + 1
    Next i

End Function

Function CompteEtabFamille(x As String, y As String) As Long
    Dim i As Long

    For i = 1 To UBound(Tbl, 1)
        'si famille=x et lieu=y alors compte
        If Tbl(i, 1) = x And Tbl(i, 7) = y Then CompteEtabFamille = CompteEtabFamille + 1
    Next i

End Function

 

[erics83]

Merci Bebere,

Je n'ai pas pu tester le code....il bloque à chaque déclaration de Dictionary :

DicoEtabFam As Dictionary
Dim MonDico As New Dictionary

J'ai changé mon ordi, (car avec Mac, Dictionary ne fonctionne pas) et suis W10, et lorsque je lance le code, il bloque à ces niveaux là... Dans le doute, j'ai mis "Microsoft activex data object" dans les préférences....mais rien de changé....
Je fais une fausse manip ?

Merci pour votre aide,

 

[Bebere]

bonjour
Eric menu outils ,préférences et dans la liste choisir
Microsoft Scripting runtime et cocher la case
si tu fais une recherche dans le forum sur dictionary et mac il y a des solutions
ou visite le site de Jacques Boisgontier
si çà ne va tjrs pas tu remets
' Set MonDico = CreateObject("Scripting.Dictionary")
tu changes les variables dictionary en object

 

[erics83]

Merci Bebere,

Panique du débutant...lol....je savais qu'il fallait rajouter une préférence, mais je n'ai pas pris la bonne....
Oui, merci, j'ai vu les solutions qu'apporte JB pour Mac en utilisant Collection.

Par contre, le code ne fonctionne pas pour le tri : il ne fait pas les 5 premiers par famille, je pense que cela vient de

b = Ws.Range("AK2:AK6")    '5 etab pour recherche

puisqu'on prend toujours cette référence (de 2 à 6), il doit peut-être manquer un tri sur les familles permettant de ne prendre que ces références, ou autres...

Je mets un fichier "light" pour test.

Merci pour ton aide,

 

[Bebere]

bonjour Eric,Bisson Nicole,le forum
Oublié le tri famille,je m'en occupe
j'aurais du le voir puisque le résultat n'était pas le même

 

[Bebere]

bonjour
Eric ne pas tenir compte du post précédent