Comparaison BD: Macro trop "lourde"
Bonjour à tous,
J'utilise une macro pour repérer et souligner la présence de contenu identique dans deux bases de données. La macro fonctionne plutôt bien, néanmoins, les bases de données peuvent contenir jusqu'à 50.000 lignes, et là, ça rame
Voici la macro actuelle et en pièce jointe un extrait de BD:
Sub CompareAndHighlight()
Dim rng1 As Range, rng2 As Range, i As Long, j As Long
For i = 1 To Sheets("Feuil1").Range("A" & Rows.Count).End(xlUp).Row
Range(Selection, Selection.End(xlDown)).Select
Set rng1 = Sheets("Feuil1").Range("A" & i)
For j = 1 To Sheets("Feuil2").Range("A" & Rows.Count).End(xlUp).Row
Set rng2 = Sheets("Feuil2").Range("A" & j)
If StrComp(Trim(rng1.Text), Trim(rng2.Text), vbTextCompare) = 0 Then
rng1.Interior.Color = RGB(255, 255, 0)
End If
Set rng2 = Nothing
Next j
Set rng1 = Nothing
Next i
End Sub
Auriez-vous une astuce pour soulager le travail?
De plus, j'aimerais ajouter à cette comparaison de cellule équivalente, deux comparaisons partielles, à savoir:
- présence d'une chaîne égale à ce qui se trouve avant le @ et souligner en Feuil1 l'équivalence détectée
- présence d'une chaîne égale à ce qui se trouve après le @ et souligner en Feuil1 l'équivalence détectée
ex:
Feuil1
Jak.wier@Ionis.com
Todd.Peterson@SyntheticGenomics.com
Dave.jales@Ionis.com
Feuil2
Todd.Schwier@Ionis.com
Todd.Peterson@DenovoBiopharma.com
Dave.jales@Ionis.com
Un tout grand merci d'avance pour vos suggestions
Vincent
bonjour
suggestion :
dans chaque table, créer 2 colonnes
une extrayant la chaîne à gauche de @
une une extrayant la chaîne à droite de @
tirer les formules vers le bas, ou mieux, mettre sous forme de tableau, Excel recopie alors seul les formules
ensuite,
http://boisgontierjacques.free.fr/pages_site/Doublons.htm#DiffBD
rechercher le titre
Comparaison de 2 BD par MFC
dans tes tables, mettre tout en fond foncé, appliquer la méthode Boisgontier et mettre en MFC sur fond blanc
ce qui reste foncé est donc non doublon dans l'autre table.
pas de VBA, donc rapidité et fiabilité.
Bonjour,
Méthode la + rapide (comparaison entre dictionnaires)
http://boisgontierjacques.free.fr/pages_site/Dictionnaire.htm#ElementsCommuns2Listes
Sub Communs()
a = Range("A2:A" & [A65000].End(xlUp).Row)
Set MonDico1 = CreateObject("Scripting.Dictionary")
For Each c In a
MonDico1(c) = ""
Next c
b = Range("C2:C" & [C65000].End(xlUp).Row)
Set MonDico2 = CreateObject("Scripting.Dictionary")
For Each c In b
If MonDico1.exists(c) Then If Not MonDico2.exists(c) Then MonDico2(c) = ""
Next c
[G2].Resize(MonDico2.Count, 1) = Application.Transpose(MonDico2.keys)
End Sub
Ceuzin
Bonjour,
Pour une recherche exacte entre les deux bases (la coloration est faite sur la feuille "Feuil2") :
Sub Exacte()
'*** <--- lignes à supprimer si il n'y a pas de doublon dans la feuille "Feuil2"
Dim Dico As Object
Dim Cle As Variant
Dim PlgF1 As Range
Dim PlgF2 As Range
Dim CelF1 As Range
Dim CelF2 As Range
Dim Chaine As String
Dim Adr As String '***
Set Dico = CreateObject("Scripting.Dictionary")
With Worksheets("Feuil1"): Set PlgF1 = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp)): End With
With Worksheets("Feuil2"): Set PlgF2 = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp)): End With
'dédoublonne
For Each CelF1 In PlgF1
Chaine = Left(CelF1.Value, InStr(CelF1.Value, "@") - 1)
If Chaine <> "" Then Dico(CelF1.Value) = Chaine: Chaine = ""
Next CelF1
For Each Cle In Dico.Keys
Set CelF2 = PlgF2.Find(Cle, , xlValues, xlWhole)
If Not CelF2 Is Nothing Then
Adr = CelF2.Address '***
Do '***
CelF2.Interior.Color = RGB(255, 255, 0)
Chaine = Right(CelF2.Value, Len(CelF2.Value) - InStr(CelF2.Value, "@"))
If (Cle & "@" & Chaine) <> CelF2 Then CelF2.Offset(, 1).Interior.Color = RGB(255, 255, 0)
Set CelF2 = PlgF2.FindNext(CelF2) '***
Loop While CelF2.Address <> Adr '***
End If
Next Cle
End Sub
Cette sub pour une recherche partielle du début et fin d'adresse (la coloration est faite sur la feuille "Feuil2" avec en colonne B et C les début est fins d'adresses). Il y aura probablement des adaptations à faire :
Sub Partielle()
Dim Dico As Object
Dim Cle As Variant
Dim PlgF1 As Range
Dim PlgF2 As Range
Dim CelF1 As Range
Dim CelF2 As Range
Dim Debut As String
Dim Fin As String
Dim Pos As Integer
Dim Adr As String
Set Dico = CreateObject("Scripting.Dictionary")
With Worksheets("Feuil1"): Set PlgF1 = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp)): End With
With Worksheets("Feuil2"): Set PlgF2 = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp)): End With
'dédoublonne en récupérant d'un coté le début de la chaine pour une recherche partielle (la clé)
'et de l'autre coté la fin de la chaine (valeur de la clé)
For Each CelF1 In PlgF1
Pos = InStr(CelF1.Value, "@")
Debut = Left(CelF1.Value, Pos - 1)
Fin = Right(CelF1.Value, Len(CelF1.Value) - Pos)
If Debut <> "" Then Dico(Debut) = Fin: Debut = "": Fin = ""
Next CelF1
'parcour maintenant le dictionnaire à la recherche des correspondances entre les plages
For Each Cle In Dico.Keys
'la recherche est partielle
Set CelF2 = PlgF2.Find(Cle, , xlValues, xlPart) 'xlPart = partielle, xlWhole = exacte
'si trouvée...
If Not CelF2 Is Nothing Then
Adr = CelF2.Address
'...boucle sur les occurences
Do
'colore en jaune la cellule de la feuille "Feuil2" colonne A
'colore celle d'à coté en rouge si le début de l'adresse est identique mais que la fin est différente
CelF2.Interior.Color = RGB(255, 255, 0)
If Cle & "@" & Dico(Cle) <> CelF2 Then CelF2.Offset(, 1).Interior.Color = RGB(255, 0, 0)
Set CelF2 = PlgF2.FindNext(CelF2)
Loop While CelF2.Address <> Adr
End If
Next Cle
'passe à la recherhe des fins d'adresses en vidant le dico
Dico.RemoveAll
For Each CelF1 In PlgF1
Pos = InStr(CelF1.Value, "@")
Debut = Left(CelF1.Value, Pos - 1)
Fin = Right(CelF1.Value, Len(CelF1.Value) - Pos)
If Debut <> "" Then Dico(Fin) = Debut: Debut = "": Fin = ""
Next CelF1
'parcour maintenant le dictionnaire à la recherche des correspondances entre les plages
For Each Cle In Dico.Keys
'la recherche est partielle
Set CelF2 = PlgF2.Find(Cle, , xlValues, xlPart) 'xlPart = partielle, xlWhole = exacte
'si trouvée...
If Not CelF2 Is Nothing Then
Adr = CelF2.Address
'...boucle sur les occurences
Do
'colore la cellule de la colonne C en bleu si la fin de l'adresse est identique mais que le début est différent
If Dico(Cle) & "@" & Cle <> CelF2 Then CelF2.Offset(, 2).Interior.Color = RGB(0, 0, 255)
Set CelF2 = PlgF2.FindNext(CelF2)
Loop While CelF2.Address <> Adr
End If
Next Cle
End Sub