XL 2010 Module de classe avec Dictionary

[cathodique]

Bonsoir,

Je n'ai jamais monté de module de classe tout seul. Et encore moins avec un dictionnaire.

J'ai suivi un tuto (en Allemand, je n'ai rien compris aux explications), je n'ai pas lâché le morceau m'aidant de Google pour la traduction des commentaires du code.

En gros, il utilise un module de classe pour cumuler des heures et récupérer plus de 2 données dans le dictionnaire.
Son code fonctionne parfaitement bien.

J'ai voulu modifier un peu son code pour, au lieu de faire le cumul, compter le nombre d’occurrences.

Et pour aller plus, supprimer toutes les clés qu'on rencontre plus d'une fois.

Pour ceux et celles qui n'ouvrent jamais les fichiers joints voici le code.

Dans module standard

Option Explicit
Sub ResultatDictionary()
   Dim dic As Dictionary, key As Variant, lig As ListRow

   Set dic = RemplirDictionary

   With Feuil2.ListObjects("TbResultat")
      'Vider le tableau
      If Not .DataBodyRange Is Nothing Then .DataBodyRange.Delete
      'boucle sur toutes les clés du dictionnaire
      For Each key In dic
         'Ajouter une ligne au tableau
         Set lig = .ListRows.Add
         lig.Range(, 1) = dic(key).Societe
         lig.Range(, 2) = dic(key).HeurTrav
         lig.Range(, 3) = dic(key).LaDate
      Next key
   End With
End Sub

Function RemplirDictionary() As Dictionary
'on ajoute as dictionary
'Activer bibliothèque Microsoft Runtime Scripting
   Dim dic As New Dictionary
   Dim cel As Range
   'on declare variable du module de classe
   Dim HeureTravail As ClsHtravail

   'parcourir toutes les cellules des entreprises
   For Each cel In Range("TbSource[Société]")
      'Vérifiez si l'entreprise existe dans le dictionnaire
      If dic.Exists(cel.Value) = True Then
         'compter les heures
          dic(cel.Value).HeurTrav = dic(cel.Value).HeurTrav + cel.Offset(0, 1).Value

         'Déterminez la date de fin
         If dic(cel.Value).LaDate < cel.Offset(0, 2).Value Then dic(cel.Value).LaDate = cel.Offset(0, 2).Value

      Else
         'initialisation de la classe
         Set HeureTravail = New ClsHtravail
         'on rempli(alimente) la classe
         HeureTravail.Societe = cel.Value
         HeureTravail.HeurTrav = cel.Offset(0, 1).Value
         HeureTravail.LaDate = cel.Offset(0, 2).Value

         Set dic(cel.Value) = HeureTravail
      End If
   Next cel
   'Définir la valeur de retour pour la fonction
   Set RemplirDictionary = dic
End Function

Dans module de classe

Option Explicit

Public Societe As String
Public HeurTrav As Double
Public LaDate As Date

En vous remerciant par avance.

 

[dysorthographie]

pour ce qui concerne les collection, je ne vois pas qui ça pourrait intéresser mais on ne sais jamais

 

[patricktoulon]

tiens la méthode Dico Only réorganisée comme le modèle avec la classe

Option Explicit

Dim Dico As Object
Function getListDico()
    Dim cel As Range, myarray, K
    Set Dico = CreateObject("scripting.dictionary")
    For Each cel In ThisWorkbook.Sheets("Source").Range("TbSource").Columns(1).Cells
        If Not Dico.Exists(cel.Text) Then
            Dico(cel.Text) = Array(cel.Text, 1, cel.Offset(, 2).Value, cel.Offset(, 1).Value)
        Else
            myarray(0) = Dico(cel.Text)
            myarray(1) = myarray(1) + 1
            myarray(3) = myarray(3) + cel.Offset(, 1)
            If CDate(cel.Offset(, 2)) > CDate(myarray(2)) Then myarray(2) = CDate(cel.Offset(, 2).Value)
            Dico(cel.Text) = myarray
        End If
    Next
End Function


Sub tableauCumulByDico()
    Dim K, LiG
    getListDico
    With Feuil2.ListObjects("TbResultat")
        'Vider le tableau
        If Not .DataBodyRange Is Nothing Then .DataBodyRange.Delete
        'boucle sur toutes les clés du dictionnaire
        For Each K In Dico.Keys
            'Ajouter une ligne au tableau
            Set LiG = .ListRows.Add
            LiG.Range(, 1) = Dico(K)(0)
            LiG.Range(, 2) = Dico(K)(3)
            LiG.Range(, 3) = Dico(K)(2)
        Next K
    End With
End Sub

Sub tableauoccurences2ByDico()
    Dim K, LiG
    getListDico
    With Feuil4.ListObjects("TbResultat2")
        'Vider le tableau
        If Not .DataBodyRange Is Nothing Then .DataBodyRange.Delete
        'boucle sur toutes les clés du dictionnaire
        For Each K In Dico.Keys
            'Ajouter une ligne au tableau
            Set LiG = .ListRows.Add
            LiG.Range(, 1) = Dico(K)(0)
            LiG.Range(, 2) = Dico(K)(1)
            LiG.Range(, 3) = Dico(K)(2)
        Next K
    End With
End Sub

 

[cathodique]

pour ce qui concerne les collection, je ne vois pas qui ça pourrait intéresser mais on ne sais jamais

Merci beaucoup. Je n'en demandais pas autant.
Sois en sûr que j'en ferai bon usage.

Bonne soirée.

 

[cathodique]

tiens la méthode Dico Only réorganisée comme le modèle avec la classe

Option Explicit

Dim Dico As Object
Function getListDico()
    Dim cel As Range, myarray, K
    Set Dico = CreateObject("scripting.dictionary")
    For Each cel In ThisWorkbook.Sheets("Source").Range("TbSource").Columns(1).Cells
        If Not Dico.Exists(cel.Text) Then
            Dico(cel.Text) = Array(cel.Text, 1, cel.Offset(, 2).Value, cel.Offset(, 1).Value)
        Else
            myarray(0) = Dico(cel.Text)
            myarray(1) = myarray(1) + 1
            myarray(3) = myarray(3) + cel.Offset(, 1)
            If CDate(cel.Offset(, 2)) > CDate(myarray(2)) Then myarray(2) = CDate(cel.Offset(, 2).Value)
            Dico(cel.Text) = myarray
        End If
    Next
End Function


Sub tableauCumulByDico()
    Dim K, LiG
    getListDico
    With Feuil2.ListObjects("TbResultat")
        'Vider le tableau
        If Not .DataBodyRange Is Nothing Then .DataBodyRange.Delete
        'boucle sur toutes les clés du dictionnaire
        For Each K In Dico.Keys
            'Ajouter une ligne au tableau
            Set LiG = .ListRows.Add
            LiG.Range(, 1) = Dico(K)(0)
            LiG.Range(, 2) = Dico(K)(3)
            LiG.Range(, 3) = Dico(K)(2)
        Next K
    End With
End Sub

Sub tableauoccurences2ByDico()
    Dim K, LiG
    getListDico
    With Feuil4.ListObjects("TbResultat2")
        'Vider le tableau
        If Not .DataBodyRange Is Nothing Then .DataBodyRange.Delete
        'boucle sur toutes les clés du dictionnaire
        For Each K In Dico.Keys
            'Ajouter une ligne au tableau
            Set LiG = .ListRows.Add
            LiG.Range(, 1) = Dico(K)(0)
            LiG.Range(, 2) = Dico(K)(1)
            LiG.Range(, 3) = Dico(K)(2)
        Next K
    End With
End Sub

Dico J'ADOOORE.

Merci beaucoup. J'ai lu plusieurs fois que l'on pouvait mettre dans un dico pratiquement tout ce qu'on veut.
En particulier un array, mais je n'ai jamais rencontré d'exemple.
Tu viens de m'en donner un. Ce qui m'a dérouté c'est comment lire le dico, mais pas comment alimenter mon ListObject.

Stp, aurais-tu un exemple sur les dicos imbriqués?

Avec mes sincères remerciements.

Bonne soirée.

 

[Dranreb]

Les Dictionnary et les Collection peuvent contenir tout ce que peut contenir un Variant, ce qui inclut les objets et les tableaux.
Mon module MGigogne comporte une fonction DicoGig qui renvoie un Dictionary fabriqué à partir d'une collection renvoyée par la fonction Gigogne. Mais je n'en ai guère eu besoin jusqu'ici. Bien sûr elle peut remplacer les collections Co des SsGr d'origine par des Dictionary, imbriqués, donc, en une seule instruction, vu qu'elle est récursive.

 

[laurent950]

Stp, aurais-tu un exemple sur les dicos imbriqués?

On reste dans le module de classe ?
Ou ont sort du module de classe ?
@Dranreb en a fait un sublime avec récursivité, Dico imbriqué et classe imbriqué
Si tu veux je la poste @cathodique
Mais il faudrait repartir sur une autres base exemple

Sont code est magnifique
Publié dans la discussion 'Arborescence/Récursivité (Transformation d'une arborescence en Base de Données)' https://excel-downloads.com/threads...nce-en-base-de-donnees.20059069/post-20447506

 

[dysorthographie]

un peux de détente

 

[cathodique]

On reste dans le module de classe ?
Ou ont sort du module de classe ?
@Dranreb en a fait un sublime avec récursivité, Dico imbriqué et classe imbriqué
Si tu veux je la poste @cathodique
Mais il faudrait repartir sur une autres base exemple

Sont code est magnifique
Publié dans la discussion 'Arborescence/Récursivité (Transformation d'une arborescence en Base de Données)' https://excel-downloads.com/threads...nce-en-base-de-donnees.20059069/post-20447506

Bonjour @laurent950 ,

En réalité, je voudrais tout apprendre mais je sais que ça ne sera pas possible.
Chaque personne a ses capacités physique et intellectuelle.
J'ai fait beaucoup de recherches sur le forum. Très souvent, je ne trouve rien. Je pense que je ne sais pas choisir mes critères de recherche. Et, je finis par ouvrir une discussion.

Quant aux codes de notre ami @Dranreb. Je sais qu'il est très fort et je t'assure que je suis gêné lorsqu’il intervient dans mes discussions et me propose ses modules gigognes. J'ai essayé de les comprendre sans succès. D'ailleurs, leur écriture est très condensée, avec mon niveau ça me décourage de poursuivre.

Si tu juges que c'est compréhensible pour un initié tout juste moyen. Oui, je suis partant.
Merci beaucoup.
Bonne journée.

 

[cathodique]

un peux de détente

Bonjour @dysorthographie ,

Merci beaucoup. Ludique mais très intéressant.
J'espère en tirer quelque chose dans le sens apprentissage.

Avec tous mes remerciements.

Bonne journée.

 

[Dranreb]

Mais bon sang pourquoi ? Lorsque vous invoquez la propriété Value d'un objet Range, il y a énormément de code machine derrière pour aller rechercher dans la représentation en mémoire du classeur la valeur associée dans la bonne feuille à la cellule conventionnellement représentée par cet objet Range. Vous n'avez aucune idée de la façon dont ça marche, c'est très complexe (et long à exécuter, d'ailleurs), et pourtant ça ne vous empêche pas de l'utiliser ! Alors pourquoi ne pourriez vous pas utiliser une collection renvoyée par ma fonction Gigogne sans savoir comment elle a été fabriquée ? Il faut juste savoir ce qu'elle contient, comment paramétrer la fonction pour qu'elle le contienne et pas comment elle est fabriquée !

 

[jclaborde]

J'en conclue que ça ne vous intéresse pas.
Je reproduis quand même le code :

Sub RésultatGigogne()
   Dim ClnDon As Collection, TRésu(), SGrSoc As SsGr, L As Long, TDét()
   Set ClnDon = Gigogne([TbSource], 1, Null, 3)
   ReDim TRésu(1 To ClnDon.Count, 1 To 4)
   For Each SGrSoc In ClnDon
      L = L + 1
      TRésu(L, 1) = SGrSoc.Id ' Le nom de la société
      TRésu(L, 2) = SGrSoc.Count ' Le nombnre d'occurrences
      TDét = SGrSoc.DonnéesDébut: TRésu(L, 3) = TDét(3) ' Date la plus ancienne
      TDét = SGrSoc.DonnéesFin: TRésu(L, 4) = TDét(3) ' Date la plus récente
      Next SGrSoc
   TableauRetaillé([TbResultat2].ListObject) = TRésu
   End Sub

bonjour
j'ai une erreur de type sur
SGrSoc As SsGr (excel 2019)
faut-t-il ajouter une référence ?
merci

 

[Dranreb]

Bonjour @jclaborde
Non, il faut glisser/déplacer le module de classe SsGr

 

[jclaborde]

Bonjour @jclaborde
Non, il faut glisser/déplacer le module de classe SsGr

merci
je n'ai pas ce module de classe

 

[Dranreb]

Vous ne devez pas avoir le module MGigogne non plus alors, logiquement …
Tout est là dedans :

 

[cathodique]

Mais bon sang pourquoi ? Lorsque vous invoquez la propriété Value d'un objet Range, il y a énormément de code machine derrière pour aller rechercher dans la représentation en mémoire du classeur la valeur associée dans la bonne feuille à la cellule conventionnellement représentée par cet objet Range. Vous n'avez aucune idée de la façon dont ça marche, c'est très complexe (et long à exécuter, d'ailleurs), et pourtant ça ne vous empêche pas de l'utiliser ! Alors pourquoi ne pourriez vous pas utiliser une collection renvoyée par ma fonction Gigogne sans savoir comment elle a été fabriquée ? Il faut juste savoir ce qu'elle contient, comment paramétrer la fonction pour qu'elle le contienne et pas comment elle est fabriquée !

J'en déduis que c'est à moi que tu t'adresses.
1. Il me faudrait consacré beaucoup de temps pour apprendre ce que font toutes tes fonctions et apprendre à les paramétrer. Mais surtout m'en souvenir.

2. Je sais que derrière mon clavier et mon écran, il y du code que je vois pas qui gère tout. Or, ici on voit bien le code. Personnellement, bien qu'autodidacte en VBA, j'aime bien comprendre un minimum.

Toi même as dû faire beaucoup d'efforts pour apprendre, comprendre avant de faire tes codes.

Très souvent, tu me proposes tes modules de services (beaucoup de code) pour une opération qui ne nécessite que quelques lignes de code. Je sais qu'ils sont très efficaces mais nécessite, pour ma part beaucoup de temps pour apprendre à les utiliser. Voilà, pourquoi je ne m'en sers pas pour le moment.

En espérant, avoir été sincère et honnête avec toi.

Bonne journée.