XL 2010 Comment lire array dans item dictionnaire

[cathodique]

Bonjour,

Je reviens avec un autre souci. De ma précédente discussion, j'ai adapté un code de @patricktoulon.
Le code fonctionne bien mais encore faire des trucs.

Option Explicit
Sub test2()
   Dim Dico As Object, cel As Range, myarray, k
   Dim i As Integer
   Set Dico = CreateObject("scripting.dictionary")
   For Each cel In ThisWorkbook.Sheets("Feuil1").Range("TbAfectAnimal").Columns(2).Cells

      If Not Dico.Exists(cel.Text) Then
         Dico(cel.Text) = Array(cel.Text, 1, cel.Offset(, 2).Value)
      Else
         myarray = Dico(cel.Text)
         myarray(1) = myarray(1) + 1
         Dico(cel.Text) = myarray
      End If
   Next
   'tes 3 valeurs pour chaque NoDOSSIER ,sont dans les items du dico (sous la forme d'un array)
   'a savoir  [ NoDossier ,  occurence  , IdPerson]
   For Each k In Dico.Keys
      Debug.Print Join(Dico(k), " | ")
   Next
End Sub

Je voudrais supprimer toutes les clés dont l'occurrence est >1 et ensuite copier celles qui restent dans le tableau de la feuil2.
J'arrive à lire les clés comme ceci dans une boucle

for i=0 to dico.count-1
debug.print dico.keys()(i)
next i

Mais je n'arrive pas à lire les items.

Merci pour votre aide.

 

[laurent950]

Bonsoir @cathodique , @patricktoulon , @dysorthographie

suite au code effectué avec un module standard

XL 2010 - Comment lire array dans item dictionnaire

Bonjour, Je reviens avec un autre souci. De ma précédente discussion, j'ai adapté un code de @patricktoulon. Le code fonctionne bien mais encore faire des trucs. Option Explicit Sub test2() Dim Dico As Object, cel As Range, myarray, k Dim i As Integer Set Dico =...

excel-downloads.com

Voici Maintenant le code avec un module de classe

Le dictionnaire interne pDico stocke des instances distinctes de la classe ClsTab, agissant comme des "photocopies" indépendantes de la classe. Chaque clé du dictionnaire correspond à une instance unique de ClsTab, permettant de gérer plusieurs objets ClsTab séparément au sein de la classe.

Module de classe : ClsTab

Option Explicit
' Déclaration des variables privées
Private pDico As Object ' Dictionnaire pour stocker les objets ClsTab
Private pMyarray As Variant ' Tableau 2D pour stocker les valeurs
Private PCpt As Integer ' Compteur pour suivre les occurrences
Private pK As Variant ' Clé pour le dictionnaire
Private pCel As Range ' Référence à une cellule
'
' Constructeur (initialisation par défaut)
Private Sub Class_Initialize()
    Set pDico = CreateObject("scripting.dictionary") ' Crée une nouvelle instance du dictionnaire
End Sub
'
' Constructeur optionnel avec paramètre de cellule
Public Sub Init(ByVal Value As Range)
    Set pCel = Value ' Définit la cellule cible
End Sub
'
' Propriété Get/Let pour pMyarray (Tableau 2D | Get : Retourne les valeurs du tableau / Let : Définit la valeur du tableau)
Public Property Get Myarray() As Variant: Myarray = pMyarray: End Property
Public Property Let Myarray(Value As Variant): pMyarray = Value: End Property
' Propriété Get/Let pour PCpt (Compteur | Get : Retourne le compteur / Let : Définit le compteur)
Public Property Get Compteur() As Integer: Compteur = PCpt: End Property
Public Property Let Compteur(Value As Integer): PCpt = Value: End Property
' Propriété Get/Set pour pDico (Dictionnaire | Get : Retourne le dictionnaire / Set : Définit le dictionnaire)
Public Property Get Dico() As Object: Set Dico = pDico: End Property
Public Property Set Dico(Value As Object): Set pDico = Value: End Property
'
' Fonction pour récupérer ou créer un objet ClsTab associé à la clé de la cellule
Public Function Item() As ClsTab
    On Error Resume Next ' Ignore les erreurs potentielles
    Set pDico = Me.Dico ' Récupère le dictionnaire actuel
    Set Item = pDico(pCel.Text) ' Tente de récupérer l'objet ClsTab à partir du dictionnaire
    If Err Then
    On Error GoTo 0 ' Désactive On Error Resume Next pour ne pas masquer d'autres erreurs
        Set Item = New ClsTab ' Crée un nouvel objet ClsTab si la clé n'existe pas
            Item.Myarray = Range(Cells(pCel.Row, 1), Cells(pCel.Row, 5)) ' Initialise Myarray avec une plage de cellules
            Item.Compteur = Item.Compteur + 1 ' Incrémente le compteur
            pDico.Remove pCel.Text ' Supprime la clé existante (s'il y en a une)
            Set Item.Dico = pDico ' Associe le dictionnaire à l'objet ClsTab
            pDico.Add pCel.Text, Item ' Ajoute le nouvel objet ClsTab au dictionnaire avec la clé
    Else
            Item.Compteur = Item.Compteur + 1 ' Incrémente le compteur si l'objet existe déjà
    End If
End Function
'
' Destructeur pour nettoyer les ressources
Private Sub Class_Terminate()
    Set pDico = Nothing ' Libère la mémoire associée au dictionnaire
    Set pCel = Nothing ' Libère la mémoire associée à la cellule
End Sub

Puis le module standard

Option Explicit
Sub testBis()
' Déclaration des variables
    Dim cls As ClsTab ' Instance du Module de Classe ClsTab
    Dim cel As Range ' Référence à chaque cellule de la colonne "B" de la plage "NoDossier"
'
   Set cls = New ClsTab ' Création et initialisation de l'objet ClsTab
   ' Boucle à travers chaque cellule de la colonne "B" de la plage "NoDossier"
   For Each cel In ThisWorkbook.Sheets("Feuil1").Range("TbAfectAnimal").Columns(2).Cells
        ' Initialisation de l'objet ClsTab avec la cellule actuelle
            cls.Init cel
        ' Appel de la fonction Item pour récupérer ou créer une instance ClsTab à partir du dictionnaire
        ' et la réassigner à l'objet cls
            Set cls = cls.Item()
   Next
'
' Déclaration des variables supplémentaires pour traiter les résultats
    Dim ClsTemp As ClsTab ' Instance temporaire de ClsTab pour manipuler les éléments du dictionnaire
    Dim DicoTemp As Object ' Dictionnaire temporaire pour stocker les éléments de ClsTab
    Dim k As Variant ' Variable pour parcourir les clés du dictionnaire
    Dim LiG As ListRow ' Représente une ligne dans un tableau structuré (ListObject)
    Dim Myarray As Variant ' Tableau pour stocker les valeurs

' Accéder au tableau structuré "TbRes" sur la feuille "Feuil2"
    With Feuil2.ListObjects("TbRes")
    ' Vider le tableau structuré s'il contient des données
        If Not .DataBodyRange Is Nothing Then .DataBodyRange.Delete
      
        ' Parcourir chaque clé dans le dictionnaire de l'objet cls
        For Each k In cls.Dico
            Set ClsTemp = cls.Dico(k) ' Récupérer l'instance ClsTab associée à la clé actuelle
                If ClsTemp.Compteur = 1 Then ' Si le compteur de l'instance est égal à 1 (occurrence unique)
                    ' Ajouter une nouvelle ligne au tableau structuré
                        Set LiG = .ListRows.Add
                     ' Copier les valeurs de l'array dans la nouvelle ligne du tableau
                        LiG.Range(1, 1).Resize(1, 5).Value = ClsTemp.Myarray
                 Else
                ' Je voudrais supprimer toutes les clés dont l'occurrence est > 1
                 ' Supprimer l'entrée du dictionnaire si l'occurrence est supérieure à 1
                    cls.Dico(k).Dico.Remove k
                End If
        Next k
    End With
  
 ' Libération des objets pour déclencher le destructeur et libérer les ressources mémoire
    Set cls = Nothing ' Libère l'instance principale de ClsTab
    Set ClsTemp = Nothing ' Libère l'instance temporaire de ClsTab
    Set DicoTemp = Nothing ' Libère le dictionnaire temporaire (même s'il n'est pas utilisé ici)
End Sub

 

[cathodique]

Bonsoir @cathodique , @patricktoulon , @dysorthographie

suite au code effectué avec un module standard

XL 2010 - Comment lire array dans item dictionnaire

Bonjour, Je reviens avec un autre souci. De ma précédente discussion, j'ai adapté un code de @patricktoulon. Le code fonctionne bien mais encore faire des trucs. Option Explicit Sub test2() Dim Dico As Object, cel As Range, myarray, k Dim i As Integer Set Dico =...

excel-downloads.com

Voici Maintenant le code avec un module de classe

Le dictionnaire interne pDico stocke des instances distinctes de la classe ClsTab, agissant comme des "photocopies" indépendantes de la classe. Chaque clé du dictionnaire correspond à une instance unique de ClsTab, permettant de gérer plusieurs objets ClsTab séparément au sein de la classe.

Module de classe : ClsTab

Option Explicit
' Déclaration des variables privées
Private pDico As Object ' Dictionnaire pour stocker les objets ClsTab
Private pMyarray As Variant ' Tableau 2D pour stocker les valeurs
Private PCpt As Integer ' Compteur pour suivre les occurrences
Private pK As Variant ' Clé pour le dictionnaire
Private pCel As Range ' Référence à une cellule
'
' Constructeur (initialisation par défaut)
Private Sub Class_Initialize()
    Set pDico = CreateObject("scripting.dictionary") ' Crée une nouvelle instance du dictionnaire
End Sub
'
' Constructeur optionnel avec paramètre de cellule
Public Sub Init(ByVal Value As Range)
    Set pCel = Value ' Définit la cellule cible
End Sub
'
' Propriété Get/Let pour pMyarray (Tableau 2D | Get : Retourne les valeurs du tableau / Let : Définit la valeur du tableau)
Public Property Get Myarray() As Variant: Myarray = pMyarray: End Property
Public Property Let Myarray(Value As Variant): pMyarray = Value: End Property
' Propriété Get/Let pour PCpt (Compteur | Get : Retourne le compteur / Let : Définit le compteur)
Public Property Get Compteur() As Integer: Compteur = PCpt: End Property
Public Property Let Compteur(Value As Integer): PCpt = Value: End Property
' Propriété Get/Set pour pDico (Dictionnaire | Get : Retourne le dictionnaire / Set : Définit le dictionnaire)
Public Property Get Dico() As Object: Set Dico = pDico: End Property
Public Property Set Dico(Value As Object): Set pDico = Value: End Property
'
' Fonction pour récupérer ou créer un objet ClsTab associé à la clé de la cellule
Public Function Item() As ClsTab
    On Error Resume Next ' Ignore les erreurs potentielles
    Set pDico = Me.Dico ' Récupère le dictionnaire actuel
    Set Item = pDico(pCel.Text) ' Tente de récupérer l'objet ClsTab à partir du dictionnaire
    If Err Then
    On Error GoTo 0 ' Désactive On Error Resume Next pour ne pas masquer d'autres erreurs
        Set Item = New ClsTab ' Crée un nouvel objet ClsTab si la clé n'existe pas
            Item.Myarray = Range(Cells(pCel.Row, 1), Cells(pCel.Row, 5)) ' Initialise Myarray avec une plage de cellules
            Item.Compteur = Item.Compteur + 1 ' Incrémente le compteur
            pDico.Remove pCel.Text ' Supprime la clé existante (s'il y en a une)
            Set Item.Dico = pDico ' Associe le dictionnaire à l'objet ClsTab
            pDico.Add pCel.Text, Item ' Ajoute le nouvel objet ClsTab au dictionnaire avec la clé
    Else
            Item.Compteur = Item.Compteur + 1 ' Incrémente le compteur si l'objet existe déjà
    End If
End Function
'
' Destructeur pour nettoyer les ressources
Private Sub Class_Terminate()
    Set pDico = Nothing ' Libère la mémoire associée au dictionnaire
    Set pCel = Nothing ' Libère la mémoire associée à la cellule
End Sub

Puis le module standard

Option Explicit
Sub testBis()
' Déclaration des variables
    Dim cls As ClsTab ' Instance du Module de Classe ClsTab
    Dim cel As Range ' Référence à chaque cellule de la colonne "B" de la plage "NoDossier"
'
   Set cls = New ClsTab ' Création et initialisation de l'objet ClsTab
   ' Boucle à travers chaque cellule de la colonne "B" de la plage "NoDossier"
   For Each cel In ThisWorkbook.Sheets("Feuil1").Range("TbAfectAnimal").Columns(2).Cells
        ' Initialisation de l'objet ClsTab avec la cellule actuelle
            cls.Init cel
        ' Appel de la fonction Item pour récupérer ou créer une instance ClsTab à partir du dictionnaire
        ' et la réassigner à l'objet cls
            Set cls = cls.Item()
   Next
'
' Déclaration des variables supplémentaires pour traiter les résultats
    Dim ClsTemp As ClsTab ' Instance temporaire de ClsTab pour manipuler les éléments du dictionnaire
    Dim DicoTemp As Object ' Dictionnaire temporaire pour stocker les éléments de ClsTab
    Dim k As Variant ' Variable pour parcourir les clés du dictionnaire
    Dim LiG As ListRow ' Représente une ligne dans un tableau structuré (ListObject)
    Dim Myarray As Variant ' Tableau pour stocker les valeurs

' Accéder au tableau structuré "TbRes" sur la feuille "Feuil2"
    With Feuil2.ListObjects("TbRes")
    ' Vider le tableau structuré s'il contient des données
        If Not .DataBodyRange Is Nothing Then .DataBodyRange.Delete
    
        ' Parcourir chaque clé dans le dictionnaire de l'objet cls
        For Each k In cls.Dico
            Set ClsTemp = cls.Dico(k) ' Récupérer l'instance ClsTab associée à la clé actuelle
                If ClsTemp.Compteur = 1 Then ' Si le compteur de l'instance est égal à 1 (occurrence unique)
                    ' Ajouter une nouvelle ligne au tableau structuré
                        Set LiG = .ListRows.Add
                     ' Copier les valeurs de l'array dans la nouvelle ligne du tableau
                        LiG.Range(1, 1).Resize(1, 5).Value = ClsTemp.Myarray
                 Else
                ' Je voudrais supprimer toutes les clés dont l'occurrence est > 1
                 ' Supprimer l'entrée du dictionnaire si l'occurrence est supérieure à 1
                    cls.Dico(k).Dico.Remove k
                End If
        Next k
    End With
 
 ' Libération des objets pour déclencher le destructeur et libérer les ressources mémoire
    Set cls = Nothing ' Libère l'instance principale de ClsTab
    Set ClsTemp = Nothing ' Libère l'instance temporaire de ClsTab
    Set DicoTemp = Nothing ' Libère le dictionnaire temporaire (même s'il n'est pas utilisé ici)
End Sub

Bonjour @laurent950 ,

Très gentil de ta part. J'ai exécuté ton code au pas à pas (F8) et plusieurs (F5). Mais le résultat n'est pas là.
Le code ajoute 4 lignes dans le tableau (nombre d'occurrence exacte) mais les lignes sont vides de données.
J'ai essayé même avec la classe en public.

Merci beaucoup.

Bon week-end

 

[cathodique]

Bonjour @cathodique

Vous pouvez poster votre fichier excel je vais regarder.
Le code est conforme et le résultat est obligatoirement présent. Je vais vérifier les variables sur votre Excel

Le fichier a été joint au post#1. Merci

 

[cathodique]

En poste #1 le code Avec module de classe n'y ai pas inclus.

Évidemment que le code avec module de classe n'y est pas. C'est le fichier que j'ai joins pour résoudre le problème. J'ai testé sur le même fichier qui est enregistré chez moi.

Bizarrement, en voulant te joindre le fichier avec tes codes, il a fonctionné, le tableau n'est plus vide.
Désolé, pour le dérangement.

Bonne journée.