Dico pour remplacer sommeprod

Bonjour,

dans mon fichier ci annexé, je dois compter un nombre de dossiers pour base de données et ensuite un nombre de club par activité sportive; par formule, ça ne pose par de problème mais malgré un pc tout récent et 24Mg de ram, c'est très lent.

Mes colonnes N et O sont donc correcte mais la formule en colonne N devrait être remplacée par un code vba que je ne sais pas faire.

La formule pour mon nombre de dossier est refaite en vba, OK (voir les colonnes R et S) .

Je cherche à présent à faire la même chose pour ma colonne N que vous verrez sur ma feuille.

Je tiens à faire ceci en VBA pour la raison de lenteur évoquée plus haut.

Y-a-t-il une personne ici qui pourrait me dire comment faire en VBA et si possible avec dico pour ma culture générale des dico pour accélérer le processus; on imagine cette formule avec 15.000 lignes ...

Merci !!!

Patrick

16compte-rapide.xlsm (256.06 Ko)

Bonjour Patrick,

Une solution par dico comme souhaitée. On traite en plus les plages de données dans des variables tableau pour accélerer le traitement.

1/2 s pour environ 30000 lignes chez moi.

J'ai commenté le code pour éclaircir.

Sub NbClubs()
    Dim derlign As Long, i As Long
    Dim tblBenef, tblDiscipline
    Dim dicoBenef As Object, dicoDiscipline As Object

    Dim t

    t = Timer

    'désactive la mise à jour de l'écran
    Application.ScreenUpdating = False

    'dernière ligne
    derlign = Range("A" & Rows.Count).End(xlUp).Row

    'met les données dans des variables tableau pour traitement plus rapide
    tblBenef = Range("D6:D" & derlign).Value2
    tblDiscipline = Range("H6:H" & derlign).Value2

    Set dicoBenef = CreateObject("Scripting.Dictionary")
    Set dicoDiscipline = CreateObject("Scripting.Dictionary")

    'ignore la casse des clés de dico
    dicoBenef.CompareMode = vbTextCompare
    dicoDiscipline.CompareMode = vbTextCompare

    dicoDiscipline(tblDiscipline(LBound(tblDiscipline), 1)) = "Nb dossiers"

    For i = LBound(tblDiscipline) + 1 To UBound(tblDiscipline)

        'si la discipline n'existe pas, on l'ajoute en initialisant les compteurs à 0
        If Not dicoDiscipline.exists(tblDiscipline(i, 1)) Then dicoDiscipline(tblDiscipline(i, 1)) = 0

        'on regarde si le bénéficiaire existe déjà dans notre dico
        's'il n'existe pas, on l'ajoute et on incrémente
        's'il existe déjà, cela signifie qu'on l'a déjà ajouté une fois au dico. On passe
        If Not dicoBenef.exists(tblBenef(i, 1) & "$" & tblDiscipline(i, 1)) Then

            'on ajoute le bénéficiaire au dico des bénéficiaires
            dicoBenef(tblBenef(i, 1) & "$" & tblDiscipline(i, 1)) = 0

            'on incrémente la discipline de 1
            dicoDiscipline(tblDiscipline(i, 1)) = dicoDiscipline(tblDiscipline(i, 1)) + 1

        End If

    Next i

    'liste des disciplines (a priori pas besoin de les coller car déjà fait lors du compte des dossiers)
    'Range("R7").Resize(dicoDiscipline.Count) = Application.Transpose(dicoDiscipline.keys)

    'nb de dossiers par discipline
    Range("T6:T" & derlign).ClearContents
    Range("T6").Resize(dicoDiscipline.Count).Value2 = Application.Transpose(dicoDiscipline.items)

    'vide les dicos de la mémoire
    Set dicoBenef = Nothing
    Set dicoDiscipline = Nothing

    MsgBox "Temps de traitement (en s) : " & Timer - t

End Sub

Edit : Code réadapté pour tenir compte des cas où plusieurs disciplines pour 1 même bénéficiaire.

28compte-rapide-v1.xlsm (223.21 Ko)

Bonjour vba-new et le forum,

Merci !!!! pour le code et les explications.

Je t'ai envoyé un MP pour une petite question si tu veux bien

Patrick

re,

Peux-tu me dire alors ce qui se passe ici ?

J'ai des #N/A en bout de colonnes

Merci

Option Explicit

Sub NbClubs() ' 02/2016
Dim F1 As Worksheet
Dim Dico, Dico2
Dim A, B, C
Dim Temp
Set F1 = Sheets("feuil1")
Set Dico = CreateObject("Scripting.Dictionary")
Set Dico2 = CreateObject("Scripting.Dictionary")
For Each C In F1.[DISCIPLINE__SPORTIVE] ' zone nommée pour plus clarté
Temp = C.Value & C.Offset(, -4)
If Not Dico.Exists(Temp) Then
Dico(Temp) = Dico(Temp) & Temp
Dico2(C.Value) = Dico2(C.Value) + 1
End If
Next C
A = Dico.keys
B = Dico.items
[t6].Resize(Dico.Count, 1) = Application.Transpose(Dico2.items)
End Sub

Sub NbDossiers() ' OK 02/2016
Dim F1 As Worksheet
Dim Dico, Dico2
Dim A, B, C
Dim Temp
Set F1 = Sheets("feuil1")
Set Dico = CreateObject("Scripting.Dictionary")
Set Dico2 = CreateObject("Scripting.Dictionary")
For Each C In F1.[DISCIPLINE__SPORTIVE]
Temp = C.Value & "¦" & C.Offset(, -4)
Dico(Temp) = IIf(Dico.Exists(Temp), Dico(Temp) + 1, 1)
Dico2(C.Value) = Dico2(C.Value) + 1
Next C
A = Dico.keys
B = Dico.items
[q:v].ClearContents
[R6].Resize(Dico.Count, 1) = Application.Transpose(Dico2.keys)
[S6].Resize(Dico.Count, 1) = Application.Transpose(Dico2.items)
End Sub

Le problème venait de là :

[t6].Resize(Dico.Count, 1) = Application.Transpose(Dico2.items)

C'est mieux comme ça :

[t6].Resize(Dico2.Count, 1) = Application.Transpose(Dico2.items)

Ta plage cible doit être redimensionnée à la même taille que ta plage source.

Si ta plage cible est plus grande que la plage source, la différence sera remplie avec des #NA car ton Dico2 contient moins d'éléments que Dico.

Je ne sais pas si je suis clair

Mes commentaires pour la première procédure :

Sub NbClubs()    ' 02/2016
    Dim F1 As Worksheet
    Dim Dico As Object, Dico2 As Object    '<-- être le plus précis possible dans la déclaration des variables afin de ne pas utiliser de la mémoire pour rien
    'Dim A, B, C    '<-- inutile, pas utilisé
    Dim Temp As String    '<-- même remarque que plus haut

    Set F1 = Sheets("feuil1")
    Set Dico = CreateObject("Scripting.Dictionary")
    Set Dico2 = CreateObject("Scripting.Dictionary")

    'parcours de toutes les cellules de la plage
    For Each C In F1.[DISCIPLINE__SPORTIVE]    ' zone nommée pour plus clarté
        Temp = C.value & C.Offset(, -4)
        If Not Dico.Exists(Temp) Then
            Dico(Temp) = Temp
            Dico2(C.value) = Dico2(C.value) + 1
        End If
    Next C

    'A = Dico.keys    '<-- inutile, pas utilisé
    'B = Dico.items    '<-- inutile, pas utilisé

    'le resize est faux
    'Dico.Count comptait plus d'éléments que Dico2
    'ex : si Dico.Count=10 mais Dico2.Count=4, les 6 éléments restants sont remplis avec des #NA
    '[t6].Resize(Dico.Count, 1) = Application.Transpose(Dico2.items)
    [t7].Resize(Dico2.Count, 1) = Application.Transpose(Dico2.items)

    'par principe, on vide les dicos de la mémoire
    Set Dico = Nothing
    Set Dico2 = Nothing
End Sub

Mise à part la déclaration non optimale des variables et l'erreur de taille de dico lors de l'écriture des données dans la feuille, ta première procédure marche bien ! Elle marche même mieux que la mienne car je n'avais pas compris qu'un même bénéficiaire pouvait avoir plusieurs disciplines (j'ai édité mon message précédent pour corriger la macro).

Super !!

Un grand merci pour tes explications !

Je vais tenter d'appliquer ce que tu as écris

Patrick

re vba-new et le forum,

tu auras compris pourquoi je cherchais à faire un code VBA (en partie réussi tout seul, ouf ) car la formule que j'utilisais

=SOMMEPROD((1/NB.SI(BÉNÉFICIAIRE;BÉNÉFICIAIRE)*(Discipline__sportive=M7))) qui est une (matricielle bien sur )

prenait un temps de racalcul fou ( DELL tout neuf et 24 Mg de Ram pourtant).

Si la demande qui m'a été faite par ma compagne dans ce fichier revient régulièrement, je vais adapter le code pour y ajouter comme dans mon exemple la réponse à la droite du tableau de base et pourquoi pas demander sur quelles colonnes de la base il faut faire ce genre de travail.

P.

Rechercher des sujets similaires à "dico remplacer sommeprod"