Copier-coler des lignes sans doublons sur 2 critères

[Maddad]

Bonjour à tous,


Je cherche à copier des lignes sélectionnées sur deux critéres d'une feuille "A" vers une feuille "B", voici la macro:

Sub essai()

Dim fin&, fin1&

Application.ScreenUpdating = False
   
        fin = Worksheets("Compil_validations").Range("A" & Rows.Count).End(xlUp).Row
        fin1 = Worksheets("Pertes").Range("A" & Rows.Count).End(xlUp).Row
   
        For i = 2 To fin
            For a = 4 To fin1
                If Worksheets("Compil_validations").Cells(i, 1) = Worksheets("Pertes").Cells(a, 1) And   Worksheets("Compil_validations").Cells(i, 73).Value <> Worksheets("Pertes").Cells(a, 73).Value Then
                  
                  Worksheets("Compil_validations").Select
                        Range("A" & i, "BV" & i).Select
                    Selection.Copy
                Sheets("Pertes").Select
                Range("A" & Range("A65536").End(xlUp).Row + 1).Select
                ActiveCell.PasteSpecial Paste:=xlPasteValuesAndNumberFormats
    
                  Else: GoTo 1
                End If
                GoTo 2
1            Next a
2          Next i


Sheets("Pertes").Select

Range("A3:BW" & Range("A65536").End(xlUp).Row).Select


Selection.Sort Key1:=Range("A3"), order1:=xlAscending, Header:=xlYes, MatchCase:=False, Orientation:=xlTopToBottom

Range("A4:BU" & Range("A65536").End(xlUp).Row).Select

Selection.RowHeight = 65

End Sub

Mais malheureusement des doublons persistent et je n'arrive pas à trouver de solution

je n'arrive pas à mettre le fichier excel en pièce jointe car trop volumineux même après avoir supprimer des données (je ne sais pas pourquoi) , merci pour votre aide

 

[Papou-net]

Re : Copier-coler des lignes sans doublons sur 2 critères

RE :

@ Maddad :

Cette fois-ci, j'ai compris et je préfère ça !

pour répondre @ vgendron :

par contre. papou net, j'ai vu que ta macro était plus rapide. (ou du moins. y a pas tous les affichages successifs)
j'ai pas encore bien regardé ce que tu as fait pour ca.. mais. c'est un point que je vais devoir m'approprier..
pour info. dans ma macro. manquait "juste" le fin1=fin1+1...

La rapidité apparente doit être dûe au fait que j'ai désactivé le rafraîchissement d'écran en début de macro, ce qui évite un ralentissement matériel dû aux affichages successifs.

J'ai continué de regarder la question en n'utilisant qu'une seule boucle comme dans mes exemples précédents, mais je cale. J'ai donc repris ton code en utilisant des tableaux et en stockant les n° de lignes à ajouter dans un dictionnaire. Ce code paraît plus compliqué que le tien, et c'est vrai, mais il devrait améliorer sensiblement la rapidité.

Sub essaipapou()
Dim lgCibles ' Dictionnaire contenant les n° de lignes à recopier
Dim nSource() As String ' Tableau stockant les données des colonnes A:B de la feuille Compil_validations
Dim nCible() As String ' Tableau stockant les données des colonnes A:B de la feuille Pertes
Dim dlgS As Long, dlgC As Long ' Variables stockant les dernières lignes des deux feuilles
Dim celExist As Boolean ' Variable définissant si une ligne existe déjà dans la feuille Pertes
Set lgCibles = CreateObject("Scripting.dictionary")

dlgS = Feuil1.Range("A" & Rows.Count).End(xlUp).Row
dlgC = Feuil2.Range("A" & Rows.Count).End(xlUp).Row
ReDim nSource(0 To dlgS - 1, 1 To 2)
ReDim nCible(0 To dlgC - 1, C1 To 2)

Application.ScreenUpdating = False ' Suspend le rafraîchissement d'écran
' Remplissage des tableaux Source et Cible
For s = 2 To dlgS
  nSource(s - 2, 1) = Feuil1.Range("A" & s)
  nSource(s - 2, 2) = Feuil1.Range("B" & s)
Next
For c = 4 To dlgC
  nCible(c - 4, 1) = Feuil2.Range("A" & c)
  nCible(c - 4, 2) = Feuil2.Range("B" & c)
Next
' Comparaison des données source et cible
For s = 2 To UBound(nSource)
  celExist = False
  For c = 2 To UBound(nCible)
    If nSource(s - 2, 1) & nSource(s - 2, 2) = nCible(c - 2, 1) & nCible(c - 2, 2) Then
      celExist = True
      Exit For
    End If
  Next
  ' Enregistrement des n° de ligne à ajouter en feuille Pertes en évitant les doublons
  If celExist = False Then
    If Not lgCibles.exists(s) Then lgCibles.Add s, s
  End If
Next
' Boucle d'ajout des données manquantes en feuille Pertes
For Each d In lgCibles.items
  dlgC = Feuil2.Range("A" & Rows.Count).End(xlUp).Row + 1
  Feuil2.Range("A" & dlgC & ":B" & dlgC).Value = Feuil1.Range("A" & d & ":B" & d).Value
Next
' Tri des données
Sheets("Pertes").Select
Range("A3:BW" & Range("A65536").End(xlUp).Row).Select
Selection.Sort Key1:=Range("A3"), order1:=xlAscending, Header:=xlYes, MatchCase:=False, Orientation:=xlTopToBottom
Range("A1").Select
Application.ScreenUpdating = True
End Sub

A Maddad de décider la meilleure solution pour lui.

Cordialement.