XL 2013 Aide sur Dictionary : recherche et restitution

[erics83]

Bonjour,

J'essaye de comprendre l'utilisation de Dictionary (merci à JB et ses tutos qui montrent à quel point cette solution est très très rapide).

La recherche par clef est vraiment super rapide, mais je n'arrive pas à restituer :

dans mon classeur test, admettons que je veuille inscrire en Feuil3 le résultat d'une recherche dans la Feuille "BD", la recherche étant : Ville 7, pour Ami217 et avec un niveau <4, d'après ce que j'ai pu comprendre, il faut créer une clef style "Ville7|Ami217|", là où je bloque c'est comment rajouter à la clef le niveau inférieur à 4, et surtout comment restituer dans Feuil3 les résultats....
Jusqu'à présent je faisais une boucle "For I", mais j'ai un classeur avec 60000 lignes et 30 colonnes et...ça prend beaucoup de temps....d'où l'idée de passer par Dictionary (et en plus, c'est pour comprendre comment bien l'utiliser...)

Merci pour votre aide,

 

[patricktoulon]

re
tiens comme ca j'ai pas le fichier je ne peux pas tester

Option Explicit

Sub Macro1()
    Dim plage As Range, dico As Object, Tb(), i As Long, T(), chain, a&, c&
    Set dico = CreateObject("Scripting.Dictionary")
    Set plage = ThisWorkbook.Worksheets("bd").Range("A1").CurrentRegion
    Tb = plage.Value

    For i = 1 To UBound(Tb)
        If Tb(i, 5) <= 5 And Tb(i, 6) = "Ville7" And Tb(i, 7) = "Ami217" Then
         
            'on crée la chaine string pour la clé du dico
            chain = Tb(i, 1) & "|" & Tb(i, 2) & "|" & Tb(i, 3) & "|" & Tb(i, 4) & "|" & Tb(i, 5) & "|" & _
                    Tb(i, 6) & "|" & Tb(i, 7) & "|" & Tb(i, 8)

            If Not dico.exists(chain) Then 'si il n'extste pas
                dico(chain) = "" 'on le met dans le dico
                a = a + 1: ReDim Preserve T(1 To 8, 1 To a) 'et on ajoute une nouvelle colonne  au tableau(t) redimentionné dynamiquement
'(colonne parce que l'on peux redimentionner dynamiquement que la dernière dimension donc on compile transposé
                For c = 1 To 8: T(c, a) = Tb(i, c): Next ' on met les valeurs dans la nouvelle colonne du tableau
            End If

        End If
    Next i
    With Feuil2
        .Activate
        .Range("A1").CurrentRegion.ClearContents
        .Range("A1").Resize(UBound(T, 2), UBound(T)) = Application.Transpose(T)
         .Rows(1).AutoFit    'ajuste hauteur 1ère ligne
    End With
End Sub

Ps/
j'ai testé ça fonctionne

 

[patricktoulon]

re
oupss j'oubliais la ligne d' entête

et le screenupdating a false c'est instantané

Option Explicit

Sub Macro1()
    Dim plage As Range, dico As Object, Tb(), i As Long, T(), chain, a&, c&
    Set dico = CreateObject("Scripting.Dictionary")
    Set plage = ThisWorkbook.Worksheets("bd").Range("A1").CurrentRegion
    Tb = plage.Value
    For i = 1 To UBound(Tb)
        If Tb(i, 5) <= 5 And Tb(i, 6) = "Ville7" And Tb(i, 7) = "Ami217" Then
            'on crée la chaine string pour la clé du dico
            chain = Tb(i, 1) & "|" & Tb(i, 2) & "|" & Tb(i, 3) & "|" & Tb(i, 4) & "|" & Tb(i, 5) & "|" & _
                    Tb(i, 6) & "|" & Tb(i, 7) & "|" & Tb(i, 8)
            If Not dico.exists(chain) Then    'si il n'extste pas
                dico(chain) = ""    'on le met dans le dico
                a = a + 1: ReDim Preserve T(1 To 8, 1 To a)    'et on ajoute une nouvelle ligne au tableau(t) redimentionné dynamiquement
                For c = 1 To 8: T(c, a) = Tb(i, c): Next    ' on met les valeurs dans la nouvelle ligne du tableau
            End If
        End If
    Next i
    With Feuil2
        .Activate
        Application.ScreenUpdating = False
        .Range("A1").CurrentRegion.ClearContents
        .Range("A1").Resize(, UBound(T)) = Application.Index(plage.Value, 1, Array(1, 2, 3, 4, 5, 6, 7, 8))
        .Range("A2").Resize(UBound(T, 2), UBound(T)) = Application.Transpose(T)
        .Rows(1).AutoFit    'ajuste hauteur 1ère ligne
        Application.ScreenUpdating = True
    End With
End Sub

 

[erics83]

Super MERCI patricktoulon,
Merci pour les explications...oui, effectivement mon if d(c)="" ne servait à rien....

Par contre (car je ne suis vraiment à l'aise, et/ou dur de la comprenette....je n'ai pas compris

a = a + 1: ReDim Preserve T(1 To 8, 1 To a) 'et on ajoute une nouvelle colonne  au tableau(t) redimentionné dynamiquement
'(colonne parce que l'on peux redimentionner dynamiquement que la dernière dimension donc on compile transposé
                For c = 1 To 8: T(c, a) = Tb(i, c): Next ' on met les valeurs dans la nouvelle colonne du tableau

C'est le tableau dont vous me parliez, mais je ne comprends pas le fonctionnement (car j'ai envie d'apprendre et restituer, ré-utiliser). Auriez vous un tuto et/ou lien et/ou une explication sur : créer nouvelle colonne redimensionner et compilation transposé...je comprends le transposé, mais pourquoi passer par ce moyen ?

De même, on crée les clefs du dico et ensuite on ne les utilise pas...ou alors quelque chose m'aurait échappé (soif d'apprendre...)
Merci pour votre aide,

 

[patricktoulon]

re
@erics83

mais pourquoi passer par ce moyen ?

c'est simple
on ne peut pas faire en VBA
a = a + 1: ReDim Preserve T(1 To a, 1 To 8)

en VBA on ne peut que redimensionner la dernière dimension d'une variable tableau

donc : a = a + 1: ReDim Preserve T(1 To 8, 1 To a)

donc on compile dans la variable T comme ci dessous en fait

c'est pour cela que je transpose à la fin

j'utilise dans mon exemple la condition( if not dico.exists(chain))plutôt que l'alimentation directe
elle est simple a comprendre
si la chaîne n'existe pas dans le dico alors on la met dans le dico
et!!!!!! on redimensionne en même temps le tableau T de une colonne en plus
et on met les valeurs de la ligne i du tb dans la colonne a et les lignes 1 a 8 de T

au propre ca donne ça

Option Explicit

Sub Macro1()
    Dim dico As Object, tb(), i As Long, T(), chain, A&, C&
    Set dico = CreateObject("Scripting.Dictionary")
      tb = ThisWorkbook.Worksheets("bd").Range("A1").CurrentRegion.Value
    For i = 1 To UBound(tb)
        If tb(i, 5) <= 5 And tb(i, 6) = "Ville7" And tb(i, 7) = "Ami217" Then
            
            'on crée la chaine string pour la clé du dico
             chain = tb(i, 1) & "|" & tb(i, 2) & "|" & tb(i, 3) & "|" & tb(i, 4) & "|" & tb(i, 5) & "|" & _
                    tb(i, 6) & "|" & tb(i, 7) & "|" & tb(i, 8)
            
            
            
            If Not dico.exists(chain) Then    'si il n'extste pas
                dico(chain) = ""    'on le met dans le dico
                'on dimentionne en colonne car on ne peut redimentionner que la derniere dimension
                A = A + 1: ReDim Preserve T(1 To 8, 1 To A)    'et on ajoute une nouvelle colonne au tableau(t) 
                For C = 1 To 8: T(C, A) = tb(i, C): Next    ' on met les valeurs dans la nouvelle colonne du tableau
            
            'shemas
            'tableau T (ligne C , colonne A )= tableau tb( ligne i , colonne C )
            
            End If
        
        
        End If
    Next i
    With Feuil2
        .Activate
        Application.ScreenUpdating = False
        .Range("A1").CurrentRegion.ClearContents
        .Range("A1").Resize(, UBound(T)) = Application.Index(tb, 1, 0)
        .Range("A2").Resize(UBound(T, 2), UBound(T)) = Application.Transpose(T)
        .Rows(1).AutoFit    'ajuste hauteur 1ère ligne
        Application.ScreenUpdating = True
    End With
End Sub

 

[erics83]

SUPER MERCI patricktoulon pour ces explications

J'ai compris la logique ! TOP !! Merci !!!

Et juste dernière question (car nos post se sont croisés), pourquoi passer par un dico puisqu'on ne ré-utilise pas le dico par la suite ?

Merci,

 

[patricktoulon]

re

Et juste dernière question (car nos post se sont croisés), pourquoi passer par un dico puisqu'on ne ré-utilise pas le dico par la suite ?

un dico c'est quoi finalement
c'est un tableau a deux dimensions interdisant les doublons dans la colonne keys

le dico dans mes modèles m'est utile pour tester si la chain est déjà dedans ou pas
si il est déjà dedans je le met pas dans le tableau T
si il n'y est pas je le met dans le dico et le tableau T
c'est simple
en créant le tableau T directement dans la boucle dico
tu te libère du boulot avec textTocolum avec l' autres modèlede code ( de cp4 je crois)

 

[erics83]

TOP !!! Merci patricktoulon
Merci d'avoir pris le temps de me répondre et m'expliquer la logique...
C'est parfait !!!

MERCI !

Merci pour votre aide, et bon courage pour ce soir, car le mistral est en forme ce soir.......

 

[patricktoulon]

re
laurent bonsoir
tu perds la tète
tu peux pas faire simplement alors

For i = LBound(tbl) To UBound(tbl)
    If (tbl(i, 5) <= 5 And tbl(i, 6) = "Ville7" And tbl(i, 7) = "Ami217") Then    'recherche niveau<=5 et ville7 et Ami217
        chain = tbl(i, 6) & "|" & tbl(i, 7) & "|" & tbl(i, 4) & "|"  'création clef et identification ligne
        d.Add Key:=chain, Item:=Split(chain, "|")
    Next

plutot de passer par une variable type que tu compile dans une 2d boucle en plus
et pour finir tu REBOUCLE !! ligne par ligne du dico pour mettre les array qui sont dans le items
HOlalalala

puré alors depuis le temps tu a tout oublié hein ;je vais sévir !!!

mais qui a bien pu te montrer cette façon de travailler un tableau

en vba tout les chemins mènent à Rome
mais si on peut éviter de passer par Tchécoslovaquie c'est mieux

bon d'accords je sort

 

[patricktoulon]

re
@laurent950
a ben je ne sais pas si c'est top mon split ,mais puré le machin que tu nous a sorti

je salut le travail oui mais le concept non

quel est l’intérêt de ne pas compiler tout le tableau d’occurrences en même temps que le dico?

quel est l’intérêt de mettre l'array de chaque ligne bonnes dans l'item en passant par ta variable type ?

quel est l'interet de placer par la suite les array dans les lignes en feuil2 ligne par ligne?

moi je veux bien si tu me prouve que c'est plus rapide, moins lourd, ou autre gain

tiens pour la peine je vais l'essayer ton schmilblick

a ben tu l'a enlevé dommage
redonne moi ce code de fou là que je m'amuse un peu

 

[AtTheOne]

Bonsoir à tous,
J'avais dis dans le post #5 :

Sauf à faire que les items de ton dictionnaire des Villes soient des dictionnaires des Amis, qui soient eux même des dictionnaires des Niveaux qui renverraient les lignes de ton tableau... bref une usine à gaz.
ainsi MonDicVille("Ville7")("Ami217")("1") renverrait un tableau des amis217 de niveau 1 pour la ville7

et dans mon pst #10 :

bien que l'on soit éloigné de ta demande initiale : filtrer à l'aide d'un dictionnaire ?

Et comme tout le monde y va de son exemple avec Dico voici le mien.

Dans un 1er temps je constitue une imbrication de dictionnaires qui me donne pour chaque triplet Ville, Ami, Niveau les lignes complètes concernées par ce triplet.
On accède à l'extrait par monDico(Villex)(Amiy)(Nivz) mais à ce stade ça ne permet pas de recherche avec niv > valeur,

Ensuite j'affiche un formulaire avec une ListView où l'on peut choisir un opérateur (=, >= ... ). Puis j’alimente la ListView en fonction des critères choisis et à partir des dictionnaires . Enfin je propose de sauvegarder le contenu de cette ListView dans le tableau de la feuille Extrait.

L’intérêt c'est de pouvoir itérer dans le formulaire en choisissant ses critères.
L'affichage dans le formulaire est accéléré grâce aux dictionnaires construits dans le 1er temps.

C'est juste un exercice, pas sûr que cela soit très efficace, mais cela montre que les items de dicos peuvent contenir autre chose qu'une simple valeur (ici, des dicos et des tableaux).

A toi de voir

Amicalement
Alain

 

[dysorthographie]

Sub test()
Dim d As Object, tbl, it
Set d = CreateObject("Scripting.Dictionary")
With Sheets("BD").Range("A1").CurrentRegion
    tbl = .Range(.Range("A2"), .Cells(.Cells.Rows.Count, .Cells.Columns.Count)).Value
End With
With Sheets("Feuil3").Range("A1").CurrentRegion
     .Range(.Range("A2"), .Cells(.Cells.Rows.Count, .Cells.Columns.Count)).Clear
End With
For i = LBound(tbl) To UBound(tbl)
    If (tbl(i, 5) <= 5 And tbl(i, 6) = "Ville7" And tbl(i, 7) = "Ami217") Then
        d(tbl(i, 6) & "|" & tbl(i, 7) & "|" & tbl(i, 4)) = Array(tbl(i, 1), tbl(i, 2), tbl(i, 3), tbl(i, 4), tbl(i, 5), tbl(i, 6), tbl(i, 7), tbl(i, 8))
    End If
Next

it = Application.Transpose(Application.Transpose(d.items))
Sheets("Feuil3").Range("A2").Resize(d.Count, 8) = it
End Sub

 

[AtTheOne]

Bonjour @erics83, @dysorthographie ,@patricktoulon , @cp4, bonjour à tous

En lisant les commentaires de @patricktoulon sur le remplissage direct des tableaux j'ai tenté le coup dans mon système de dictionnaires imbriqués Dic(Ville)(Ami)(Niveau).

Il s'avère que, dans ce cas, un deuxième passage pour remplir les tableaux qui se trouvent au 3ème niveau est plus rapide.

Bien sûr c'est plus long à remplir que si l'on applique directement les 3 critères en exemples (Ville7, Ami217, Niveau <5).
Mais on dispose d'une description complète et quand on arrive sur le formulaire on peut choisir ses critères à loisir.
La réponse alors est plutôt rapide.

Autre plus de cette méthode, montrer que les items d'un dictionnaire peuvent contenir des objets.

Le Module M01_V1 :
(Sh_BdD la feuille contenant le tableau source, Sh_Extrait la feuille pour enregistrer l'extrait choisi)

Option Explicit
Public Const Col_Ville As Byte = 6, Col_Ami As Byte = 7, Col_Niveau As Byte = 5
Public Dic_Ville As Object
Public NbCol As Integer
'

Sub Construire_Dic()

     Dim Lo As ListObject
     Dim Tb_Val, NbLgn As Long, Tb, Opér
     Dim Ville As String, Ami As String, Niveau As Integer
     Dim KVille, KAmi, KNiv, Col
     Dim i As Long, j As Long
    
     Set Lo = Sh_BdD.ListObjects(1)
     NbLgn = Lo.ListRows.Count
     NbCol = Lo.ListColumns.Count
     If NbLgn < 1 Then Exit Sub    'le tableau source est vide, on sort
    
     Tb_Val = Lo.DataBodyRange.Value
    
     '______________________
     'Constitution des dicos
     '1ère passe toutes les clefs (avec seulement N° des lignes)
     Set Dic_Ville = CreateObject("Scripting.Dictionary")
     For i = 1 To NbLgn
          Ville = Tb_Val(i, Col_Ville): Ami = Tb_Val(i, Col_Ami): Niveau = Tb_Val(i, Col_Niveau)
          If Not Dic_Ville.Exists(Ville) Then Set Dic_Ville(Ville) = CreateObject("Scripting.Dictionary")
          If Not Dic_Ville(Ville).Exists(Ami) Then Set Dic_Ville(Ville)(Ami) = CreateObject("Scripting.Dictionary")
          If Dic_Ville(Ville)(Ami).Exists(Niveau) Then
               Dic_Ville(Ville)(Ami)(Niveau) = Dic_Ville(Ville)(Ami)(Niveau) & ";" & i
          Else
                Dic_Ville(Ville)(Ami)(Niveau) = i
          End If
     Next i
    
     '2ème passe tableaux complets pour tous les niveaux
     For Each KVille In Dic_Ville.Keys
     For Each KAmi In Dic_Ville(KVille).Keys
     For Each KNiv In Dic_Ville(KVille)(KAmi).Keys
          Tb = Split(Dic_Ville(KVille)(KAmi)(KNiv), ";")
          NbLgn = UBound(Tb) + 1
          ReDim Tb_Temp(1 To NbLgn, 1 To NbCol)
          For i = 1 To NbLgn
               For j = 1 To NbCol
                    Tb_Temp(i, j) = Tb_Val(Tb(i - 1), j)
               Next j
          Next i
          Dic_Ville(KVille)(KAmi)(KNiv) = Tb_Temp
     Next KNiv, KAmi, KVille
     'Les dicos sont constitués
     '¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯
    
     'Préparation du formulaire
     '¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯
     'Opérateurs de comparaison
     Opér = Array("=", "<>", ">=", ">", "<=", "<")
    
     'liste des villes triées
     Tb = Dic_Ville.Keys
     Tri Tb, LBound(Tb), UBound(Tb)
    
     With UsF_Critères
    
          .CBx_Opérateurs.List = Opér
          .CBx_Ville.List = Tb
          
          'Préparation de la ListView
          With .LVw_Etat
               With .ColumnHeaders
                    'Supprime les anciens entêtes
                    .Clear
                    'Création des entêtes en spécifiant leur largeur
                    For Each Col In Lo.HeaderRowRange.Cells
                         .Add , , Col.Value, Col.EntireColumn.Width * 1.45
                    Next
               End With
               'type d'affichage de la listview (tableau)
               .View = lvwReport
               .Gridlines = True
          End With
          
          .Show
     End With
     Unload UsF_Critères
     Dic_Ville.RemoveAll
     Set Dic_Ville = Nothing
    
End Sub

Sub Tri(a, gauc, droi)         ' QuickSort http://boisgontierj.free.fr
     Dim ref, temp, g, d
     ref = a((gauc + droi) \ 2)
     g = gauc: d = droi
     Do
         Do While a(g) < ref: g = g + 1: Loop
         Do While ref < a(d): d = d - 1: Loop
         If g <= d Then
               temp = a(g): a(g) = a(d): a(d) = temp
               g = g + 1: d = d - 1
         End If
     Loop While g <= d
     If g < droi Then Call Tri(a, g, droi)
     If gauc < d Then Call Tri(a, gauc, d)
End Sub

Sub Vider_LObj()

Dim Lo As ListObject
     Set Lo = Sh_Extrait.ListObjects(1)
     With Lo.Range
          .Offset(1).Resize(.Rows.Count - 1).Clear
     End With
     Lo.Resize Lo.HeaderRowRange.Resize(2)
    
End Sub

Le chargement de la listView dans le userform USF_Critères

Private Sub Charge_LVw()

     Opér = CBx_Opérateurs.Value
     If Opér = "" Then Opér = "="
     Niveau = CBx_Niveau.Value
     If Niveau = "" Then Niveau = """"""
     With LVw_Etat
          .ListItems.Clear
          k = 0
          For Each clef In Dic_Ville(CBx_Ville.Value)(CBx_Ami.Value).Keys
               If Evaluate(clef & Opér & Niveau) Then
                    Tb = Dic_Ville(CBx_Ville.Value)(CBx_Ami.Value)(CLng(clef))
                    For i = 1 To UBound(Tb, 1)
                         k = k + 1
                         .ListItems.Add , , Tb(i, 1)
                         For j = 2 To UBound(Tb, 2)
                              .ListItems(k).ListSubItems.Add , , Tb(i, j)
                         Next
                    Next
               End If
          Next clef
     End With
    
End Sub

Amicalement
Alain