Recherche de cellule équivalente sur deux feuilles (amélioration du code)

[Boris972]

Bonjour,
J'ai fais un code qui permet de regarder sur deux feuilles différentes de voir sur une plage de cellule, il y a des cellules équivalentes et si c'est le cas de faire les actions copier les cellules adjacentes puis les coller sur l'autre feuille etcc...
Ce code fonctionne très bien, mais je le trouve lent car sur une des feuilles il y a plus de 7000 lignes et sur l'autre 3000
Voici le code

Dim cellule1 As Range
Dim cellule2 As Range


                 For Each cellule1 In Sheets(1).Range("A5:A65536")
                      If cellule1.Value <> "" Then
                        Sheets("base_roue_moteur").Activate
                            For Each cellule2 In Sheets("2").Range("M5:M65536")
                                If Trim(cellule1.Value) = Trim(cellule2.Value) Then
                                    Sheets("1").Activate
                                    Range(Cells(cellule1.Row, 2), Cells(cellule1.Row, 3)).Copy
                                    Sheets("base_roue_moteur").Activate
                                    Cells(cellule2.Row, Range("A4").End(xlToRight).Offset(0, 1).Column).PasteSpecial
                                    Exit For
                                ElseIf cellule2.Value = "" Then
                                    Exit For
                         End If
                        Next cellule2
                      ElseIf cellule1.Value = "" Then
                        Exit For
                      End If
                 Next cellule1

Si vous une astuce, ou un code équivalent qui permettrait d'optimiser le temps de réalisation, je suis preneur.

Cordialement,
Boris

 

[pierrejean]

Re : Recherche de cellule équivalente sur deux feuilles (amélioration du code)

bonjour boris

et bienvenue sur XLD

Pour t'aider efficacement il serait souhaitable de disposer d'un petit fichier exemple (sans données confidentielles) avec quelques lignes par feuille et indiquant le resultat attendu

 

[Boris972]

Re : Recherche de cellule équivalente sur deux feuilles (amélioration du code)

Bonjour Pierre Jean, et merci

Donc dans le fichier, le résultat souhaité est celui obtenu une fois que la Macro "Test" est lancée (Via le bouton de commande "Macro test")
Donc la macro fonctionne bien, mais je la trouve lente, elle est peut etre un peu "bourin" et une méthode plus élegante (et surtout plus rapide) existe surement.

PS: Comme la pièce jointe est limité à 48Ko il y a beaucoup moins de lignes dans ce fichier que dans celui d'origine.

 

[pierrejean]

Re : Recherche de cellule équivalente sur deux feuilles (amélioration du code)

Re

Vois si cela te convient

 

[Boris972]

Re : Recherche de cellule équivalente sur deux feuilles (amélioration du code)

Re!

Je me rend compte que le fichier que j'ai fais correspond pas tout à fait, je l'ai rendu un peu trop idéal 🙁
(En fait il n'y a que 2 feuilles, le "Reset Données" que j'avais mis sert à rien, c'était juste pour refaire tourner la macro)

J'ai vu que vous aviez utilisé une méthode par variable tableau si je ne m'abuse.
Or en fait dans mon classeur dans les 2 feuilles les tableaux sont rarement de même dimension...


J'ai donc refait un classeur test, plus représentatif par rapport au classeur d'origine

 

[pierrejean]

Re : Recherche de cellule équivalente sur deux feuilles (amélioration du code)

Re

En supposant avoir bien compris

 

[Etienne2323]

Re : Recherche de cellule équivalente sur deux feuilles (amélioration du code)

Bonjour Boris, pierrejean, le fil,
voici un exemple avec des recherches.

Sub Test()

Dim F1, F2, Lig, La_Valeur, Cellule_Recherche
Dim PL1 As Integer, DL1 As Integer, La_Ligne As Integer, DL2 As Integer
Dim i As Integer
Dim La_Feuille As String


Set F1 = Sheets("Feuil1")
Set F2 = Sheets("Feuil2")

F1.Select
PL1 = Cells(1, 1).End(xlDown).Row + 1
DL1 = Cells(65536, 1).End(xlUp).Row

F2.Select
DL2 = Cells(65536, 1).End(xlUp).Row

For i = PL1 To DL1
    If ActiveSheet.Name <> "Feuil1" Then F1.Select
    Cellule_Recherche = Cells(i, 1).Value
    F2.Select
    Set Lig = Range(Cells(1, 1), Cells(DL2, 1)).Find(Cellule_Recherche, LookIn:=xlValues, LookAt:=xlWhole)
    If Not Lig Is Nothing Then
        La_Valeur = Cells(Lig.Row, 2).Value
    Else
        La_Valeur = "Aucune correspondance"
    End If
    F1.Select
    Cells(i, 4).Value = La_Valeur
    La_Valeur = ""
Next i

End Sub

Cordialement,

Étienne

 

[Boris972]

Re : Recherche de cellule équivalente sur deux feuilles (amélioration du code)

Re, Etienne et Pierrejean

Par rapport au code d'Etienne il ressemble beaucoup a celui que j'avais fais dans mon premier fichier et a comme défaut d'être lent lorsque le nombre de ligne devient conséquent.



Merci PierreJean pour le dernier fichier, c'est ce que je recherchais.
Je suis actuellement sur un projet et je pense que cette méthode par variable tableau va pas mal me servir.
J'ai essayé de l'adapter a une contrainte, avoir plus de colonne dans la feuille2, pouvez vous me dire si le code est correcte

 

[pierrejean]

Re : Recherche de cellule équivalente sur deux feuilles (amélioration du code)

Re

Oui le code est correct , la preuve etant qu'il fonctionne (apres suppression d'un End Sub excedentaire)