XL 2013 Aide sur Dictionary : recherche et restitution

erics83

XLDnaute Impliqué
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,
 

Pièces jointes

  • testdictionaryV2.xlsx
    710 KB · Affichages: 15

erics83

XLDnaute Impliqué
Merci Robert,
je ne comprends pas la question : j'ai ma feuille "BD", je recherche les données suivant les filtres et j'essaye de donner le résultat fans la feuil3...
Si vous faites allusion à un USB où je pourrais définir les critères, là, je sais faire (merci JB), mais là, ce qui m'intéresse c'est les filtres et tris et la restitution....

Merci pour votre aide,
 

AtTheOne

XLDnaute Impliqué
Supporter XLD
Bonjour à tous Bonjour @erics83 ,

Je ne crois pas que les dictionnaires soit la meilleure façon de traiter ton problème de filtre.
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

Le temps de construction risque d'être long.
(j'ai déjà fait cela pour la gestion d’Équipements de Protection Individuelle, mais c'était pour accéder directement à une seule information à la fois.)

Le filtre avancé est bien plus efficace.

Dans l'exemple que je joins, j'ai d'abord converti les niveaux en nombres (ils étaient sous forme de texte).
J'ai créé des tableaux structurés, et 2 macros pour effacer les anciennes extractions et pour extraire à nouveau :

VB:
Sub Effacer()
Dim Lo As ListObject

     Set Lo = Worksheets("Extraction").ListObjects("_Tb_Extraction")
     Lo.Resize Lo.HeaderRowRange.Resize(2)
     Lo.HeaderRowRange.Offset(1).Resize(Worksheets("Extraction").Rows.Count - Lo.HeaderRowRange.Row).Clear
  
End Sub

Code:
Sub Filtrer()
Dim Rg_Source As Range, Rg_Critères As Range, Rg_Extraction As Range, Lo As ListObject

     Set Rg_Source = Worksheets("BdD").[_Tb_BdD[#All]]
     Set Rg_Critères = Worksheets("Extraction").[_Tb_Critères[#All]]
     Set Rg_Extraction = Worksheets("Extraction").[_Tb_Extraction[#Headers]]
  
     Set Lo = Worksheets("Extraction").ListObjects("_Tb_Extraction")
     Lo.Resize Rg_Extraction.Resize(2)
     Rg_Extraction.Offset(1).Resize(Worksheets("Extraction").Rows.Count - Rg_Extraction.Row).Clear
  
     Rg_Source.AdvancedFilter Action:=xlFilterCopy, _
                             CriteriaRange:=Rg_Critères, _
                             CopyToRange:=Rg_Extraction, _
                             Unique:=False
     'Au cas où le filtre ne renvoie rien Tableau (ListObjet) non redimensionné
     On Error Resume Next
     Lo.Resize Rg_Extraction.CurrentRegion
     On Error GoTo 0
  
End Sub

Attention les cellules au-dessus du tableau d'extraction doivent restées vide (à cause de l'utilisation de .CurrentRegion pour le redimensionnement)

Amicalement
Alain
 

Pièces jointes

  • Filtre Avancé.xlsm
    757.4 KB · Affichages: 3

dysorthographie

XLDnaute Accro
Bonjour,
Je te propose un filtre élaboré!
j'avais pas fait attention au poste de @erics83 ,
Sub test()
Vantile "Ville7", "Ami217"
End Sub
Public Sub Vantile(Ville As String, Ami As String)
Dim F As Worksheet
Set F = ThisWorkbook.Worksheets.Add(after:=Sheets(Sheets.Count))
F.Name = "filtre"
F.Range("A1:B1") = Array("Ville", "Ami")
F.Range("A2:B2") = Array(Ville, Ami)


With Sheets("Feuil3")
Dim L As Integer: L = .Cells(.Cells.Rows.Count, "A").End(xlUp).Offset(1).Row
FiltreActif Sheets("Bd").UsedRange, F.UsedRange, .Cells(L, "A"), True
.Rows(L).Delete
.Select
End With



Application.DisplayAlerts = False
F.Delete

Application.DisplayAlerts = True
End Sub
Private Function FiltreActif(RangeSource As Range, CriterRange As Range, CopyRange As Range, Optional Unique As Boolean = True) As Boolean
FiltreActif = False
On Error Resume Next
RangeSource.AdvancedFilter Action:= _
xlFilterCopy, CriteriaRange:=CriterRange _
, CopyToRange:=CopyRange, Unique:=Unique
DoEvents
If Err = 0 Then FiltreActif = True
'MsgBox Err.Description
On Error GoTo 0
End Function
 

patricktoulon

XLDnaute Barbatruc
re
dans mon foure tout j'ai retrouver ceci:

demo.gif


VB:
Sub Macro4()
'on cherche la ligne ou se trouve (truc , machin , chose) en colonne (A,B et C)
'récuperation de l'index de ligne dans le sheets correspondant au criteres en colonnes "A.B.C"
    criteres = Array("""truc""", """machin""", """chose""")    'criteres a retenir dans le meme ordre que les colonnes
    ColonS = Array("A2:A9", "B2:B9", "C2:C9")    ' colonne a observer pour les criteres dans le meme ordre
    feuille = "Feuil1"    'nom de la feuille
    ligne = Evaluate("=MATCH(1,(" & feuille & "!" & ColonS(0) & "=" & criteres(0) & ")*(" & feuille & "!" & ColonS(1) & "=" & criteres(1) & ")*(" & feuille & "!" & ColonS(2) & "=" & criteres(2) & "),0)") + Range(ColonS(1)).Row - 1
Rows(ligne).Select
Debug.Print "=MATCH(1,(" & feuille & "!" & ColonS(0) & "=" & criteres(0) & ")*(" & feuille & "!" & ColonS(1) & "=" & criteres(1) & ")*(" & feuille & "!" & ColonS(2) & "=" & criteres(2) & "),0)" ' + Range(ColonS(1)).Row - 1
End Sub

Sub Macro5()
'on cherche la ligne ou se trouve (tutu , toto , tete) en colonne (A,B et C)
'récuperation de l'index de ligne dans le sheets correspondant au criteres en colonnes "A.B.C"
    criteres = Array("""tutu""", """toto""", """tete""")    'criteres a retenir dans le meme ordre que les colonnes
    ColonS = Array("A2:A9", "B2:B9", "C2:C9")    ' colonne a observer pour les criteres dans le meme ordre
    feuille = "Feuil1"    'nom de la feuille
    ligne = Evaluate("=MATCH(1,(" & feuille & "!" & ColonS(0) & "=" & criteres(0) & ")*(" & feuille & "!" & ColonS(1) & "=" & criteres(1) & ")*(" & feuille & "!" & ColonS(2) & "=" & criteres(2) & "),0)") + Range(ColonS(1)).Row - 1
Rows(ligne).Select
Debug.Print "=MATCH(1,(" & feuille & "!" & ColonS(0) & "=" & criteres(0) & ")*(" & feuille & "!" & ColonS(1) & "=" & criteres(1) & ")*(" & feuille & "!" & ColonS(2) & "=" & criteres(2) & "),0)" ' + Range(ColonS(1)).Row - 1
End Sub
des que tu choppe la ligne tu peux faire ce que tu veux
les arguments texte entre double guillemets les nombre sans guillemets

trouver la valeur en colonne "D" correspondant a la ligne ou l'on trouve truc , machin , chose en colonne A , B , et C

Code:
Sub macrox6()
   MsgBox Evaluate("INDEX(D1:D13,MATCH(1,(A1:A13=""truc"")*(B1:B13=""machin"")*(C1:C13=""chose""),0))")
End Sub

le même chose en formule ça donne ceci
=INDEX(D1:D13;EQUIV(1;(A1:A13="truc")*(B1:B13="machin")*(C1:C13="chose");0))

il te sera facile de transformer cela en fonction argumentée
demo.gif
 
Dernière édition:

AtTheOne

XLDnaute Impliqué
Supporter XLD
Bonjour à tous, bonjour @patricktoulon, bonjour @dysorthographie.
En effet le fitre élaboré semble mieux convenir car le filtre donné en exemple renvoie plusieurs lignes.
@erics83, peux-tu nous dire si nos réponses te conviennent, bien que l'on soit éloigné de ta demande initiale : filtrer à l'aide d'un dictionnaire ?
Amicalement
Alain
 
Dernière édition:

erics83

XLDnaute Impliqué
Bonjour et merci @patricktoulon ;), @dysorthographie ;), @AtTheOne ;), @Robert ;), @cp4 ;)

Merci pour tous vos apports, j'ai dû mal exprimer mon besoin car on est parti sur les filtres, alors que mon objectif était de travailler et m'entrainer avec Dictionary...j'ai travaillé ce week-end sur le code et....j'ai fait ça et ça fonctionne...mais je ne le trouve pas très "orthodoxe...." :)
Donc, je suis preneur de vos remarques et/ou observations

VB:
Sub Essai()

Application.Calculation = xlCalculationManual
Feuil1.Select
 Set d = CreateObject("Scripting.Dictionary")
 tbl = Range("A2:H" & [a200000].End(xlUp).Row)
 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
   clé = tbl(i, 6) & "|" & tbl(i, 7) & "|" & tbl(i, 4) & "|" & i 'création clef et identification ligne
   d(clé) = ""
End If

 Next i
 j = 0
 Dim b(): ReDim b(1 To d.Count, 1 To 8)
 For Each c In d.keys
   If d(c) = "" Then
     j = j + 1
     a = Split(c, "|")
        For k = 1 To 8
            b(j, k) = tbl(a(3), k) 'rappatriement éléments de la ligne
        Next k
  
   End If
 Next c
 
 
 'Met dans Feuil3

 Feuil2.Select
 Range("A2:H100000").Clear
  [a2].Resize(j, 8) = b
 
 
 Application.Calculation = xlCalculationAutomatic
End Sub

Merci pour votre aide,
 
Dernière édition:

cp4

XLDnaute Barbatruc
Bonjour et merci @patricktoulon ;), @dysorthographie ;), @AtTheOne ;), @Robert ;), @cp4 ;)

Merci pour tous vos apports, j'ai dû mal exprimer mon besoin car on est parti sur les filtres, alors que mon objectif était de travailler et m'entrainer avec Dictionary...j'ai travaillé ce week-end sur le code et....j'ai fait ça et ça fonctionne...mais je ne le trouve pas très "orthodoxe...." :)
Donc, je suis preneur de vos remarques et/ou observations

VB:
Sub Essai()

Application.Calculation = xlCalculationManual
Feuil1.Select
 Set d = CreateObject("Scripting.Dictionary")
 tbl = Range("A2:H" & [a200000].End(xlUp).Row)
 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
   clé = tbl(i, 6) & "|" & tbl(i, 7) & "|" & tbl(i, 4) & "|" & i 'création clef et identification ligne
   d(clé) = ""
End If

 Next i
 j = 0
 Dim b(): ReDim b(1 To d.Count, 1 To 8)
 For Each c In d.keys
   If d(c) = "" Then
     j = j + 1
     a = Split(c, "|")
        For k = 1 To 8
            b(j, k) = tbl(a(3), k) 'rappatriement éléments de la ligne
        Next k
 
   End If
 Next c
 
 
 'Met dans Feuil3

 Feuil2.Select
 Range("A2:H100000").Clear
  [a2].Resize(j, 8) = b
 
 
 Application.Calculation = xlCalculationAutomatic
End Sub

Merci pour votre aide,
Re,

à mon humble avis ton code est correct. Une autre proposition un peu plus condensée.
VB:
Option Explicit

Sub Macro1()
    Dim plage As Range, dico As Object, Tb(), i As Long, Tr()
    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
            dico(Tb(i, 1) & "|" & Tb(i, 2) & "|" & Tb(i, 3) & "|" & Tb(i, 4) & "|" & Tb(i, 5) & "|" & _
                 Tb(i, 6) & "|" & Tb(i, 7) & "|" & Tb(i, 8)) = ""
        End If
    Next i

    With Feuil2
        .Activate
        .Range("A1").CurrentRegion.ClearContents
        .Range("A1").Resize(dico.Count) = Application.Transpose(dico.Keys)
        Application.DisplayAlerts = False
        .Columns(1).TextToColumns DataType:=xlDelimited, Other:=True, OtherChar:="|"    'éclater colonne 1 en plusieurs suivant delimiteur choisi ("|")
        Application.DisplayAlerts = True
        .Rows(1).AutoFit    'ajuste hauteur 1ère ligne
    End With
End Sub
 

Discussions similaires

Statistiques des forums

Discussions
311 711
Messages
2 081 796
Membres
101 817
dernier inscrit
carvajal