Aide sur Scripting.Dictionary

[Delux]

Bonjour a tous,

(excusez moi pour les accents je suis sur QWERTY).

Je souhaite comparer deux listes de references uniques entre deux tableaux pour verifier si la reference existe deja et si oui, inserer la donnee qui correspond.

J'ai pu voir sur internet que la fonction "Scripting.Dictionary" permet d'accelerer le processus (je vais travailler sur plus de 30000 lignes).

J'arrive a l'utiliser pour trouver les doublons dans une meme colonne (feuille 2, qui correspond au nouveau tableau inporte), mais je ne trouve pas le moyen de chercher l'information dans un autre tableau (feuille 1, qui correspond a la base de donnees).

Sub Find_Duplicates_KeyDOC()
' highlight duplicates
Dim colonne, Haut, Bas, cle

Application.ScreenUpdating = False

Sheet2.Select
  
  colonne = Sheet2.Range("A:A").Column
  Haut = Sheet2.Range("A65489").End(xlUp).Row
  Bas = Selection.End(xlDown).Row
  Dim tab1
  Set tab1 = CreateObject("Scripting.dictionary")
  For Compteur = 2 To Haut
    cle = CStr(Cells(Compteur, colonne))
    If tab1.exists(cle) Then
        couleur = 45
    Else
        tab1(cle) = 1
        couleur = xlNone
    End If
    Cells(Compteur, colonne).Interior.ColorIndex = couleur
  Next

End Sub

Pourriez-vous me donner un petit coup de main?
J'ai mis un fichier exemple et j'utiliserai votre formidable solution pour la readapter a ma base de donnees

En vous remerciant par avance.

Cordialement

Delux

 

[Paf]

Re : Aide sur Scripting.Dictionary

bonjour,

Si j'ai bien compris, une solution possible est de mettre les données de la feuille 1 en tableau (MonTab), puis de comparer avec le dictionnaire déjà établi (tab1)

Derl = Worksheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row

MonTab = Worksheets("Sheet1").Range("A1:A" & Derl)
For i = 1 To UBound(MonTab)
    If tab1.exists(MonTab(i, 1)) Then
        Worksheets("Sheet1").Cells(i, 2) = "existe : " & MonTab(i, 1)
    Else
        Worksheets("Sheet1").Cells(i, 2) = "N'existe pas: " & MonTab(i, 1)
    End If
Next

Bonne suite

ps : pour plus d'info sur scripting.dictionary un lien utile ( entre autres) :Objet dictionary

 

[Delux]

Re : Aide sur Scripting.Dictionary

Salut Paf,

Merci pour votre solution, mais j'ai l'intime coinviction que mon dictionnaire se base sur la meme feuille.

En fait (dans mon vrai classeur) je dois comparer une liste de "TAG" (references uniques) dans une autre liste pour:
- savoir si il existe
- connaitre son statut (la reference a un statut)

Le fichier principale est en sheet1 et le fichier source (avec les status) est en sheet 2.

Comment dire a la macro que le dictionnaire doit correspondre a la sheet2 et les resultats doivent apparaitre en sheet1.

Je ne sais pas si c'est bien clair.

En vous remerciant par avance.

Cordialement,

Delux

 

[Paf]

Re : Aide sur Scripting.Dictionary

Re,
Dans le code du post 1, Cle prendra les valeurs de la feuille courante puisqu'elle n'est pas précisée.(cle = CStr(Cells...).
Il faudrait donc préciser la feuille;

  For Compteur = 2 To Haut
    cle = CStr(Worksheets("Sheet2").Cells(Compteur, colonne))
    If ...
       ...
    Else
       ...

bonne suite

 

[laetitia90]

Re : Aide sur Scripting.Dictionary

bonjour Delux ,Paf

en fin de compte il sont ou tes doublons???

En fait (dans mon vrai classeur) je dois comparer une liste de "TAG" (references uniques) dans une autre liste pour:

a moins qu'il soit sur sheet2 a ce compte la autant les supprimer.... la Scripting.Dictionary va être utile
mais bon en attendant plus d'explications

un code considerant pas de double.... mais pas 30000 lignes sur chaque feuille autrement il y a pour la journée

Sub es()
 Dim t, t1, a As Long, b As Long
 Application.ScreenUpdating = 0
 t = Sheet1.Range("a1:b" & Sheet1.Cells(Rows.Count, 1).End(3).Row)
 t1 = Sheet2.Range("a1:b" & Sheet2.Cells(Rows.Count, 1).End(3).Row)
 For a = LBound(t, 1) To UBound(t, 1)
 For b = LBound(t1, 1) To UBound(t1, 1)
 If t(a, 1) = t1(b, 1) Then t(a, 2) = t1(b, 2)
 Next b: Next a
 Sheet1.Range("a1").Resize(UBound(t, 1), UBound(t, 2)) = t
End Sub

 

[Delux]

Re : Aide sur Scripting.Dictionary

Paf, Laetitia90,

Merci pour votre aide.

Je ne voulais pas identifier les doublons, mais je voulais juste importer une information de la feuille 2 sur la feuille 1. Le code etait un exemple.

Voici pour info un code que j'ai trouve sur internet et que j'ai modifie pour mes besoins (quand on aime on partage)

Sub ShareCat_Status()

Dim Derlig1 As Long, Derlig2 As Long
Dim Cptr As Integer, T1_colb(), T2_colb
Dim Dico1 As Object, Dico2 As Object

'fige le défilement de l'écran
Application.ScreenUpdating = False

With Sheets("ShareCat Extract")
'initialisation et préparation feuil2
     Derlig2 = .Cells(.Rows.Count, 4).End(xlUp).Row
     
     .Range(.Cells(1, 1), .Cells(Derlig2, 4)).Interior.ColorIndex = xlNone
     'passage en ram tableau feuil2
     T2_colb = .Range(.Cells(1, 1), .Cells(Derlig2, 9)).Value
     'création du dictionnary feuille1 col b
     Set Dico2 = CreateObject("scripting.dictionary")
          For Cptr = 6 To UBound(T2_colb)
                If Not Dico2.exists(T2_colb(Cptr, 4)) Then 'élimination des éventuels doublons
                    Dico2.Add T2_colb(Cptr, 4), T2_colb(Cptr, 9)
               End If
          Next
End With

'préparations feuil1
With Sheets("Master Register")
     Derlig1 = .Cells(.Rows.Count, 1).End(xlUp).Row
     'passage en ram tableau feuille1
     T1_colb = .Range(.Cells(1, 1), .Cells(Derlig1, 1)).Value
     'création du dictionnary feuille1 col b
     Set Dico1 = CreateObject("scripting.dictionary")
          For Cptr = 3 To UBound(T1_colb)
               If Not Dico1.exists(T1_colb(Cptr, 1)) Then 'élimination des éventuels doublons
                    Dico1.Add T1_colb(Cptr, 1), ""
               End If
          Next
    
'détecte les éléments de feuil2 manquant en feuil1 _
     et les colorise en jaune
     For Cptr = 3 To UBound(T1_colb)
          If Dico2.exists(T1_colb(Cptr, 1)) Then
                .Range(.Cells(Cptr, 2), .Cells(Cptr, 2)).Value = Dico2.Item(T1_colb(Cptr, 1))
          Else
                .Range(.Cells(Cptr, 2), .Cells(Cptr, 2)).Value = "Not Created"
          End If
     Next
End With

Set Dico1 = Nothing
Set Dico2 = Nothing

End Sub

Temps d'execution ultra rapide

Merci a vous deux