Recherche valeurs identiques

  • Initiateur de la discussion Initiateur de la discussion cyrus55160
  • Date de début Date de début

Boostez vos compétences Excel avec notre communauté !

Rejoignez Excel Downloads, le rendez-vous des passionnés où l'entraide fait la force. Apprenez, échangez, progressez – et tout ça gratuitement ! 👉 Inscrivez-vous maintenant !

cyrus55160

XLDnaute Junior
Bonjour,

Je réalise une comparaison de valeurs de cellules entre deux feuilles, et si les valeurs sont identiques je colorie la cellule.Le code que j'utilise est le suivant:

Sub essai()

Application.ScreenUpdating = False

nbreligne1 = Sheets("Feuil2").Range("A13").CurrentRegion.Rows.Count
nbreligne2 = Sheets("Feuil1").Range("A3").CurrentRegion.Rows.Count

For j = 3 To 3 + nbreligne2
For i = 13 To 13 + nbreligne1
var1 = Sheets("Feuil2").Cells(i, 2).Value
var2 = Sheets("Feuil1").Cells(j, 1).Value
If var1 = var2 Then
Sheets("Feuil1").Cells(j, 1).Interior.ColorIndex = 8
End If
Next i
Next j

End Sub


Par contre, je trouve que l'éxécution est longue (il y a 30000 lignes sur une feuille et 3000 sur l'autre) et cela dure 45 minutes environ.
Est ce normal ou est il possible d'avoir un code plus rapide.
PC utilisé : pentium dual core avec 1 Go de ram

Merci
 
Re : Recherche valeurs identiques

Bonjour Cyrus, Spitnolan🙂

un essai peut être, si j'ai bien compris, pas sur...

Code:
Sub essai()
Dim nbreligne1 As Long, nbreligne2 As Long
Application.ScreenUpdating = False
nbreligne1 = Sheets("Feuil2").Range("A13").CurrentRegion.Rows.Count
nbreligne2 = Sheets("Feuil1").Range("A3").CurrentRegion.Rows.Count
For j = 3 To 3 + nbreligne2
    For i = 13 To 13 + nbreligne1
        If Sheets("Feuil2").Cells(i, 2).Value = Sheets("Feuil1").Cells(j, 1).Value Then
            Sheets("Feuil1").Cells(j, 1).Interior.ColorIndex = 8
            Exit For
        End If
    Next i
Next j
Application.ScreenUpdating = True
End Sub

bon après midi
@+
 
Re : Recherche valeurs identiques

Bonjour,

Pour améliorer la vitesse il faudrait passer par des Tableaux.
Mémoriser chaque plage dans des variables tableau1(j) et tableau2(i)
et ensuite avec des boucles For Next balayer les plages des 2 tableaux pour trouver
les correspondances.

Un fichier exemple serait plus pratique
 
Re : Recherche valeurs identiques

Bonjour,

Je te joins un fichier exemple.
J'ai comparé avec 30000 lignes sur une feuille et 3000 lignes sur une autre et le programme le fait en 40 secondes.
Tu adaptes mon code à ton cas notamment avec les couleurs. c'est du code brut et qui donne le principe.
Code:
Sub Balaye()
    Application.ScreenUpdating = False
    Sheets(1).Activate
    Range("A1").Select
    With Selection.CurrentRegion
        Intersect(.Cells, .Offset(1)).Select
    End With
    A = Selection.Value
    Application.Goto Reference:=Range("A1"), scroll:=True
    Sheets(2).Activate
    Range("A1").Select
    With Selection.CurrentRegion
        Intersect(.Cells, .Offset(1)).Select
    End With
    B = Selection.Value
    Application.Goto Reference:=Range("A1"), scroll:=True
    ReDim tableauA(1 To UBound(A), 1)
    For I = 1 To UBound(A)
        tableauA(I, 1) = A(I, 1)
    Next I
    ReDim TableauB(1 To UBound(B), 1)
    For J = 1 To UBound(B)
        TableauB(J, 1) = A(J, 1)
    Next J
    Sheets(1).Activate
    For K = 1 To UBound(A, 1)
        For L = 1 To UBound(B, 1)
              If B(L, 1) = A(K, 1) Then Cells(K + 1, 2).Value = _
                "Trouvée dans Sheets(2)": Cells(K + 1, 2).Interior.ColorIndex = 8

        Next L
    Next K
End Sub
 

Pièces jointes

Dernière édition:
Re : Recherche valeurs identiques

Re,

Une proposition utilisant find:
Code:
Sub test()

nbreligne1 = Sheets("Feuil2").Range("A13").CurrentRegion.Rows.Count

With Worksheets(1).Range(Cells(3, 1), Cells(Range("A65530").End(xlUp).Row, 1))
    For i = 13 To 13 + nbreligne1
        Set c = .Find(Sheets("feuil2").Cells(i, 1))
        If Not c Is Nothing Then
            firstAddress = c.Address
            Do
                c.Interior.ColorIndex = 7
                Set c = .FindNext(c)
            Loop While Not c Is Nothing And c.Address <> firstAddress
        End If
    Next
End With

End Sub
Cordialement

Edit : En fait dans ce cas pour gagner du temps il faut rajouter un tableau des valeurs déjà rencontrées et je pense sans avoir regarder en détail le code de Renauder que cela revient un peu à faire ce qu'il fait.

Sauf s'il est possible de trier la feuille2...
 
Dernière édition:
Re : Recherche valeurs identiques

Re,

J'arrive à comprendre le code de spitnolan08 que je vais essayer.
Par contre dans le code de RENAUDER je n'arrive pas comprendre les lignes :

Intersect(.Cells, .Offset(1)).select

et

Application.Goto Reference:=Range("A1"), scroll:=True

Merci bcp
 
Re : Recherche valeurs identiques

Re,

J'arrive à comprendre le code de spitnolan08 que je vais essayer.
Par contre dans le code de RENAUDER je n'arrive pas comprendre les lignes :

Intersect(.Cells, .Offset(1)).select

et

Application.Goto Reference:=Range("A1"), scroll:=True

Merci bcp

Intersect
C'est pour sélectionner ma plage de données sans les titres des colonnes
Goto
Vas à la cellule A1 en se déplacant (utile dans le cas ou il y a beaucoup de colonnes)
 
Re : Recherche valeurs identiques

Re,

Le code que j'ai proposé ne peut pas lutter en l'état avec celui de Renauder...
Car il boucle de trop nombreuses fois sur les mêmes valeurs pour être efficace.
Comme indiqué, si on peut trier les valeurs de la feuille 2, on peut réussir à l'améliorer. Quant à dire s'il sera ainsi aussi performant (ou plus) que celui de Renauder...

Si j'ai 5' j'essaierai...
Cordialement
 
Re : Recherche valeurs identiques

Re,

avec ce code je traite 30000 lignes sur la feuille1 et 3000 sur la feuille 2 en 6 secondes... 🙂 Sous réserve d'avoir trier par ordre croissant ou décroissant les données de la feuille2. Je te laisse vérifier si tous les cas sont bien passés en revue...
Code:
Sub test()
Dim nb As Single, nbreligne1 As Single, valeur As String
Dim Plage1 As Range, Plage2 As Range, c As Range
nbreligne1 = Sheets("Feuil2").Range("A13").CurrentRegion.Rows.Count

Set Plage1 = Sheets(1).Range("A1:A" & Range("A65530").End(xlUp).Row)
Set Plage2 = Sheets(2).Range("A1:A" & Range("A65530").End(xlUp).Row)
With Plage1
    For i = 1 To nbreligne1
        valeur = Sheets(2).Cells(i, 1)
        nb = WorksheetFunction.CountIf(Plage2, valeur)
        
        Set c = .Find(Sheets("feuil2").Cells(i, 1))
        If Not c Is Nothing Then
            firstAddress = c.Address
            Do
                c.Interior.ColorIndex = 7
                Set c = .FindNext(c)
            Loop While Not c Is Nothing And c.Address <> firstAddress
        End If
        i = i + nb - 1
    Next
End With

End Sub
Cordialement
 
Dernière édition:
Re : Recherche valeurs identiques

Bonjour,
Cela est très intéressant car il faudrait avoir un panel de données absolument identique pour voir quelle est la méthode la plus rapide.
Dans mon cas j'ai crée une plage de nombres de 1 à 30000 (incrément de 1 donc de 1 à 30000) sur la feuille 1 et une plage de nombre de 1 à 3000 (incrément de 2 donc de 2 à 6000) sur la feuille 2.

Pour Spitolan08
En prenant les données comme citées plus haut,
je constate que le résultat n'est pas correct.
Il me colore des cellules avec des nombres impairs alors que dans la feuille 2 il n'y a que des nombres pairs.
En regardant de plus près lorsque le programme lit 2 sur la feuille 2, tous les nombres de la feuille 1 ayant le chiffre 2 sont marqués comme étant identiques ce qui n'est pas le cas car on veut la valeur exacte.

Affaire à suivre ....
 
Dernière édition:
Re : Recherche valeurs identiques

Re,

Je vais regarder ça mais je pense savoir pourquoi. Pour info, j'ai travaillé sur une extension de la BD transmise par cyrus55160. Ce ne sont que des chaines de caractères et le pb que tu soulèves y est moins sensible (Voir pas du tout) compte tenu de la forme des libellés recherchés.

Cordialement
 
- Navigue sans publicité
- Accède à Cléa, notre assistante IA experte Excel... et pas que...
- Profite de fonctionnalités exclusives
Ton soutien permet à Excel Downloads de rester 100% gratuit et de continuer à rassembler les passionnés d'Excel.
Je deviens Supporter XLD

Discussions similaires

Réponses
3
Affichages
569
Réponses
16
Affichages
2 K
Réponses
33
Affichages
2 K
Retour