Comparaison BD: Macro trop "lourde"

Le 21/09/2018 à 16:00

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

15comparaison-base-de-donees.ods (3.51 Ko)
Le 21/09/2018 à 16:21

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é.

Le 21/09/2018 à 17:57

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

12compare2listes.zip (15.74 Ko)
Le 22/09/2018 à 14:15

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
Rechercher des sujets similaires à "comparaison macro trop lourde"