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.

 

[patricktoulon]

re
en fait ça serait plutot un truc du genre

for each k in dico.keys

   myarray=dico.keys(k)
   for i= lbound(myarray) to ubound(myarray)

     debug.print myarray(i)
   next i
next

 

[cathodique]

re
en fait ça serait plutot un truc du genre

for each k in dico.keys

   myarray=dico.keys(k)
   for i= lbound(myarray) to ubound(myarray)

     debug.print myarray(i)
   next i
next

Merci beaucoup. Mais plante

 

[patricktoulon]

pardon
oupss!!
, c'est myarray= dico(k)

 

[patricktoulon]

comment tu veux le retour dans ton tableau en feuille2
par ce que a ce que je vois tu ne récupère que le Nodossier et le idperson
hors ton tableau en feuille2 est le même que le tableau en feuille 1
donc tu veux récupérer les lignesa une seule occurrence

et mettre le dossier et idperson dans leur colonne respective et laisser les autres colonnes vides ?
ou
ou ton tableau de destination est différent ?

 

[cathodique]

comment tu veux le retour dans ton tableau en feuille2
par ce que a ce que je vois tu ne récupère que le Nodossier et le idperson
hors ton tableau en feuille2 est le même que le tableau en feuille 1
donc tu veux récupérer les lignesa une seule occurrence

et mettre le dossier et idperson dans leur colonne respective et laisser les autres colonnes vides ?
ou
ou ton tableau de destination est différent ?

Bonjour @patricktoulon ,

Excuses ma tardive réponse. J'ai branché à 100% sur l'autre discussion.

donc tu veux récupérer les lignesa une seule occurrence

Quoique j'ai solutionné à ma manière (il y a sûrement plus simple).
C'est exactement le but recherché.

ou ton tableau de destination est différent ?

Mon tableau de destination est sur une autre feuille (tableau à 2 colonnes)

Merci.

Bonne journée.

 

[patricktoulon]

re

 

[cathodique]

re

@patricktoulon : Merci beaucoup. Je te réponds alors que je n'ai pas visionné toute ta vidéo (pour laquelle, je te remercie.

Quant à la perplexité, je reconnais que je n'ai pas été très explicite dans l'autre discussion. Dans laquelle, j'ai joins un fichier monté pas à pas en suivant un tuto en Allemand (Or, je suis nulle en langue étrangère). je voulais comprendre certaines choses pour aller plus loin dans MON FICHIER.

Pour cette discussion, moi aussi je suis perplexe. As-tu ouvert le fichier de cette discussion?
Je ne pense pas. Sinon, tu te serai rendu compte que ce n'est pas le même tableau.

je te suis très reconnaissant. je repars poursuivre mon visionnage.

Bon après-midi.

 

[cathodique]

Voilà, je viens voir ta vidéo jusqu'au bout.
As-tu compris que j'ai suivi un tuto sur un dico avec module de classe?
N'ayant jamais codé moi même une classe, j'ai voulu joindre comme on dit, l'utile à l'agréable.
M’initiè et résoudre un problème (par manque d’expérience, j'opte pour la solution la moins adaptée).

Tu me proposes en fin de vidéo un fichier avec module de classe. Je te laisse deviner si je suis intéressé ou pas.

Au fait, s'il n'y a pas d’occurrence valant 1 , est-ce le code ne va pas planter?

Je n'avais pas compris comment lire les items.
dans un dico classique je faisais dans une boucle for each cle dico.Items
Ayant affaire à un Array, je n'avais pas compris la différence.

Merci beaucoup.

 

[dysorthographie]

Bonjour,

Sub test()
Const adVarWChar = 202, adInteger = 3, adDBDate = 133
    Dim Rs As Object, cel As Range
    Set Rs = CreateObject("ADODB.Recordset")
    With Rs
        .Fields.Append "Societe", adVarWChar, 50
        .Fields.Append "nb", adInteger
        .Fields.Append "Date", adDBDate
        .Open
      
        For Each cel In ThisWorkbook.Sheets("Source").Range("TbSource").Columns(1).Cells
            .Filter = "Societe='" & Replace(cel.Text, "'", "''") & "'"
            If .EOF Then .AddNew
            !Societe = cel.Text: !nb = !nb + 1: If !Date < cel.Offset(, 2) Then !Date = cel.Offset(, 2)
        Next
        .Filter = "nb>1": .Update: .MoveFirst
    End With
    With Feuil2.ListObjects("TbResultat")
    
        If Not .DataBodyRange Is Nothing Then .DataBodyRange.Delete
        If Not Rs.EOF Then .Parent.Cells(2, 1).CopyFromRecordset Rs
    End With
End Sub

 

[cathodique]

Bonjour,

Sub test()
Const adVarWChar = 202, adInteger = 3, adDBDate = 133
    Dim Rs As Object, cel As Range
    Set Rs = CreateObject("ADODB.Recordset")
    With Rs
        .Fields.Append "Societe", adVarWChar, 50
        .Fields.Append "nb", adInteger
        .Fields.Append "Date", adDBDate
        .Open
     
        For Each cel In ThisWorkbook.Sheets("Source").Range("TbSource").Columns(1).Cells
            .Filter = "Societe='" & Replace(cel.Text, "'", "''") & "'"
            If .EOF Then .AddNew
            !Societe = cel.Text: !nb = !nb + 1: If !Date < cel.Offset(, 2) Then !Date = cel.Offset(, 2)
        Next
        .Filter = "nb>1": .Update: .MoveFirst
    End With
    With Feuil2.ListObjects("TbResultat")
   
        If Not .DataBodyRange Is Nothing Then .DataBodyRange.Delete
        If Not Rs.EOF Then .Parent.Cells(2, 1).CopyFromRecordset Rs
    End With
End Sub

Bonjour @dysorthographie

je te remercie. mais là, je constate que toi aussi tu es resté coincé sur l'autre discussion.

 

[dysorthographie]

Je voudrais supprimer toutes les clés dont l'occurrence est >1 et ensuite copier celles qui restent dans le tableau de la feuil2.

non je ne suis pas resté coinsé sur l'autre discutions, je te propose une solution adaptable à toutes les demande similaire avec par exemple un filtre BN>1

 

[cathodique]

non je ne suis pas resté coinsé sur l'autre discutions, je te propose une solution adaptable à toutes les demande similaire avec par exemple un filtre BN>1

C'est ce que j'ai cru car le tableau et la feuille du fichier joint à cette discussion ne sont pas ce que tu as mis dans ton code.
J'ai testé avec le fichier de l'autre discussion. ça fonctionne très bien.

Tu as utilisé des "trucs" que je connais pas du tout. Je suis du genre à ne pas vouloir mourir idiot. Je voudrais faire l'effort de comprendre un minimum ton. Pourrais-tu STP, commenté ton code.

perso, j'ai fait toute une gymnastique, utiliser un dico pour compter les nombres occurrences, faire un remove du dico pour virer toutes les clés dont l'occurrence est > 1.

Ton code est très concis et fait le boulot

 

[dysorthographie]

Si l'idée est de récupérer Les numéros de dossier ayant plusieurs aucurance il y a plus simple.

Certains de proposerai à juste titre power querry. Personnellement je n'y ai pas accès mais d'autres peuvent t'accompagner.

Personnellement je pourrais t'offrir un solutions SQL ma il faudra préciser ce que tu veux sélectionné comme information et sur la base de quel filtre. Et je te donnerai un script et toutes les explications qui si rattachement.

Je vais devoir m'absenter mais j'attends t'a réponse et en fonction je m'y colle ce soir.

 

[laurent950]

Bonsoir @cathodique , @patricktoulon , @dysorthographie

Option Explicit

Sub test2()
   Dim Dico As Object
       Set Dico = CreateObject("scripting.dictionary")
   Dim k As Variant ' La clé du dictonnaire
   Dim cel As Range ' Boucle colonne "B" NoDossier (Pour comprendre ci dessous)
   Dim myarray As Variant 'Item du dictionnaire = Array(cel.Text, 1, cel.Offset(, 2).Value)
   Dim LiG As ListRow

   'NoDossier (Pour comprendre ci dessous)
   'ThisWorkbook.Sheets("Feuil1").Range("TbAfectAnimal").Columns(2).Select
   For Each cel In ThisWorkbook.Sheets("Feuil1").Range("TbAfectAnimal").Columns(2).Cells
      If Not Dico.Exists(cel.Text) Then
         ' La clé du dictonnaire = cel.Text | l'Item du dictionnaire = Array(cel.Text, 1, cel.Offset(, 2).Value)
           Dico(cel.Text) = Array(cel.Offset(, -1).Text, _
                                  cel.Text, _
                                  1, _
                                  cel.Offset(, 1).Value, _
                                  cel.Offset(, 2).Value, _
                                  cel.Offset(, 3).Value)
      Else
         myarray = Dico(cel.Text)
         myarray(2) = myarray(2) + 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)lse
   'a savoir  [ NoDossier ,  occurence  , IdPerson]

    With Feuil2.ListObjects("TbRes")
    ' Vider le tableau
        If Not .DataBodyRange Is Nothing Then .DataBodyRange.Delete
        For Each k In Dico
            myarray = Dico(k)
                If myarray(2) = 1 Then
                    ' Ajouter une ligne au tableau
                        Set LiG = .ListRows.Add
                        myarray = Dico(k)
                            LiG.Range(, 1) = myarray(0)
                            LiG.Range(, 2) = myarray(1)
                            'Le_compteur = myarray(2) ' Le compteur
                            LiG.Range(, 3) = myarray(3)
                            LiG.Range(, 4) = myarray(4)
                            LiG.Range(, 5) = myarray(5)
                    Debug.Print Join(Dico(k), " | ") 'tes 3 valeurs pour chaque NoDOSSIER
                 Else
                    ' Je voudrais supprimer toutes les clés dont l'occurrence est > 1
                      Dico.Remove k
                End If
        Next k
    End With
End Sub