Chercher cellules identiques de colonne P en colonnes G et L et exporter

Bonjour à tous,

Le code mis en application dans ce classeur est fonctionnel mais il est assez lent, c’est pour cela que je demande aux experts parmi vous une solution avec Tableaux (UBound) combiné à dictionnaire (Si c'est possible) car c’est beaucoup plus rapide.

Dans l’exemple avec des données réduites, le code semble fonctionner rapidement mais avec des données importantes, il mets un certain temps.

Voici donc les explications sur ce que le code doit faire :

Il compare chaque cellule de la colonne "P" à partir de "P2" avec les cellules des colonnes "G" et "L" à partir de "G2" et "L2".

1. Lorsqu’il trouve une cellule identique en colonne "G", il exporte la valeur de la cellule qui se trouve à gauche de la cellule en colonne "G" (donc = à valeur de la cellule en colonne "F") en colonne "Q", ensuite, il exporte la valeur de la cellule qui se trouve à droite (donc = à valeur de la cellule en colonne "H") en colonne "R"
2. S’il trouve une 2^e cellule identique en colonne "G", on exporte la valeur de la cellule "F" en colonne "S" et on exporte la valeur de la cellule "H" en colonne "T" et ainsi de suite jusqu’à la fin.

Petit exemple mis en couleur dans la feuille "Comparaison" :

On commence par la cellule en "P2", la valeur de la cellule "P2" = "3024-066/2020 M", on retrouve la même valeur dans la cellule "G2", alors, on exporte la valeur de la cellule "F2" dans la cellule "Q2" et celle de la cellule "H2" dans la cellule "R2"

Ensuite, on retrouve encore la même valeur en "G5", alors on exporte la valeur de la cellule "F5" dans la cellule "S2" et celle de la cellule "H5" dans la cellule "T2" et ainsi de suite jusqu’à la fin des tests en colonne "G".

Lorsque la recherche en colonne "G" est terminée, nous continuerons la recherche dans la colonne "L" à partir de la cellule "L2" jusqu'à la dernière cellule en colonne "L".

Lorsque cette étape est terminée, nous ferons de même pour la cellule située en "P3".

Je reste à votre disposition pour d’autres informations si besoin.

Merci d’avance pour vos contributions et à vous lire.

Bonjour,

Essayez ceci

Sub Transferer()
    Dim lr As Long, LR1 As Long, LR2 As Long, i As Long, Col_Dest As Long, DerLig As Long
    Dim Plage As String, Deb As String
    Dim x As Range
    Application.ScreenUpdating = False
    lr = Cells(Rows.Count, "P").End(xlUp).Row
    LR1 = Cells(Rows.Count, "G").End(xlUp).Row
    LR2 = Cells(Rows.Count, "L").End(xlUp).Row
    DerLig = Application.Max(lr, LR1, LR2)

    Plage = "G2:G" & DerLig & ", L2:L" & DerLig
    For i = 2 To lr
        Col_Dest = 17
        With Sheets("Comparaison").Range(Plage)
            Set x = .Find(Cells(i, "P"), LookAt:=xlWhole, SearchOrder:=xlByColumns)
            If Not x Is Nothing Then
                Deb = Cells(x.Row, x.Column).Address
                Do
                    Cells(i, Col_Dest) = Cells(x.Row, x.Column - 1)
                    Cells(i, Col_Dest + 1) = Cells(x.Row, x.Column + 1)
                    Set x = .FindNext(x)
                    Col_Dest = Col_Dest + 2
                Loop While Not x Is Nothing And Cells(x.Row, x.Column).Address <> Deb
            End If
        End With
    Next i
End Sub

Cdlt

Bonjour Arturo83

Merci pour votre retour et le code proposé.

On avance très bien, le code que vous m’avez proposé me donne le résultat souhaité et il est plus rapide que le mien. Bravo.

Pour l’utilisation réelle avec toutes mes données, le mien met : 21,2031 secondes, le vôtre met : 9.2266 secondes.

C’est parfait, je suis content de votre code que je mettre en lieu et place du mien, merci encore.

Par défi personnel, je vais regarder si je peux mettre en application (Malgré que je n’ai aucune notion sur l’utilisation des tableaux (UBound)), pour justement voir si je peux encore améliorer le temps d’exécution.

Cordialement.

Bonjour,

Proposition avec Dictionnaire comme vous le souhaitez:

Sub Transferer_Via_Dico()
    Dim DerLig_P As Long, DerLig_G As Long, DerLig_L As Long, i As Long, Col_Dest As Long, DerLig As Long
    Dim Plage As String, Deb As String
    Dim itemIndex As Long
    Dim x As Range
    Application.ScreenUpdating = False
    Supprimer_Données
    DerLig_P = Range("P" & Rows.Count).End(xlUp).Row
    DerLig_G = Range("G" & Rows.Count).End(xlUp).Row
    DerLig_L = Range("L" & Rows.Count).End(xlUp).Row
    DerLig = Application.Max(DerLig_P, DerLig_G, DerLig_L)
    Plage = "G2:G" & DerLig & ", L2:L" & DerLig

    Set Liste = CreateObject("Scripting.Dictionary")
    For i = 2 To DerLig_P
        For Each c In Range(Plage)
            If c <> Cells(i, "P") Then
                Liste.Item(c.Row) = Array(c.Offset(0, -1), c.Offset(0, 1))
           End If
        Next c
        If Liste.Count > 0 Then
            itemIndex = 0
            For Each Item In Liste.items
                Cells(i, "Q").Offset(0, itemIndex).Value = Item(0)
                Cells(i, "R").Offset(0, itemIndex).Value = Item(1)
                itemIndex = itemIndex + 2
            Next Item
        End If
        Liste.RemoveAll
    Next i
End Sub

Sub Supprimer_Données()
    If Cells(2, "Q") <> "" Then
        DerLig = Range("P2").CurrentRegion.Rows.Count
        Range(Cells(2, "Q"), Cells(DerLig, "ZZ")).ClearContents
    End If
End Sub

Cdlt

Bonjour Arturo83,

Merci pour votre retour et le nouveau code avec Dictionnaire.

Juste un mot, Magnifique, le code fonctionne très bien, très rapide et me donne le résultat souhaité, Que souhaitez de plus !

Je vous remercie encore et au plaisir de vous lire pour une prochaine demande, qui sait ?

Cordiale poignée de mains.