Comment vérifier les doublons dans 2 colonnes et copier la ligne entière dans une autre feuille ?

Question

Je veux vérifier les doublons dans les colonnes A et F. Si l'une d'entre elles contient un doublon, j'ai besoin que la macro copie la ligne entière dans un autre fichier du même classeur.

S'il vous plaît, que quelqu'un m'aide. Voici la macro que j'ai écrite pour vérifier les doublons dans A et ensuite copier la ligne entière dans une nouvelle feuille nommée "dup".

    Option Explicit
    Sub FindCpy()
    Dim lw As Long
    Dim i As Integer
    Dim sh As Worksheet

    Set sh = Sheets("Dup")
    lw = Range("A" & Rows.Count).End(xlUp).Row

    For i = 1 To lw 'Find duplicates from the list.
    If Application.CountIf(Range("A" & i & ":A" & lw), Range("A" & i).Text) > 1 Then
     Range("B" & i).Value = 1
    End If
    Next i

    Range("A1:B10000").AutoFilter , Field:=2, Criteria1:=1
    Range("A2", Range("A65536").End(xlUp)).EntireRow.Copy
    sh.Range("A65536").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
    Selection.AutoFilter
    End Sub

Answer 1

Si vous voulez vérifier si tout de la cellule A ou de la cellule F est dupliquée dans sa propre colonne, il vous suffit de Or les deux conditios :

If (Application.CountIf(Range("A" & i & ":A" & lw), Range("A" & i).Text) > 1) Or _
 (Application.CountIf(Range("F" & i & ":F" & lw), Range("F" & i).Text) > 1) Then

D'autre part, si vous voulez que le duplicata soit en comparant simultanément les colonnes A et F à d'autres lignes, alors vous devrez CountIfs

If Application.CountIfs(Range("A" & i & ":A" & lw), Range("A" & i).Text, _
    Range("F" & i & ":F" & lw), Range("F" & i).Text) > 1 Then

Enfin, le Selection.Autofilter et les plages non qualifiées dans le code (qui est correct à part cela) peuvent causer des problèmes. Il vaut mieux utiliser des plages qualifiées et des noms de feuilles explicites.

EDIT

Vous pouvez vous faciliter la tâche en utilisant des colonnes entières pour la correspondance :

'Case 1:
If (Application.CountIf(Range("A:A"), Range("A" & i).Text) > 1) Or _
 (Application.CountIf(Range("F:F"), Range("F" & i).Text) > 1) Then

'Case 2:
If Application.CountIfs(Range("A:A"), Range("A" & i).Text, _
    Range("F:F"), Range("F" & i).Text) > 1 Then

En utilisant le cas 1, et avec une certaine amélioration de votre code pour que nous utilisions des plages qualifiées, votre code devient comme ceci, (veuillez lire attentivement les commentaires) :

Option Explicit

Sub FindCpy()
  Dim lw As Long, i As Long
  With ActiveSheet ' <------ use an explicit sheet if you can i.e. With Sheets("srcSheet")
     lw = .Range("A" & .Rows.count).End(xlUp).row
     For i = 2 To lw ' <----------- start at row 2, row 1 must be a header to use autofilter
       If (Application.CountIf(.Range("A:A"), .Range("A" & i).text) > 1) Or _
       (Application.CountIf(.Range("F:F"), .Range("F" & i).text) > 1) Then
            .Range("B" & i).value = 1
        End If
    Next i
    With .Cells.Resize(lw)
        .AutoFilter Field:=2, Criteria1:=1
        .Offset(1).Copy
        Sheets("Dup").Range("A65536").End(xlUp).Offset(1).PasteSpecial xlPasteValues
        .AutoFilter
     End With
  End With
  Application.CutCopyMode = False
End Sub

Answer 2

Si vous voulez faire cela en filtrant, je vous suggère d'utiliser le filtre avancé qui intègre la méthode de copie. Par exemple :

Option Explicit
Sub DupFilter()
 Dim wsSrc As Worksheet, wsDup As Worksheet
 Dim rSrc As Range, rDup As Range, rCrit As Range, rCell1 As Range
 Dim sCritRange1 As String, sCritRange2 As String

 'set worksheets and ranges
 On Error Resume Next
 Set wsDup = Worksheets("Dup")
    If Err.Number = 9 Then _
        Worksheets.Add.Name = "Dup"
 On Error GoTo 0
 Set wsDup = Worksheets("Dup")
    Set rDup = wsDup.Cells(1, 1)

 Set wsSrc = Worksheets("sheet1")
 With wsSrc
    Set rCell1 = .Cells.Find(what:="User Name", after:=.Cells(1, 1), LookIn:=xlValues, lookat:=xlWhole, _
          searchorder:=xlByRows, searchdirection:=xlNext, MatchCase:=False)
    Set rSrc = .Range(rCell1, .Cells(.Rows.Count, rCell1.Column).End(xlUp)).Resize(columnsize:=6)
    Set rCrit = .Range(.Cells(1, 7), .Cells(3, 7))
 End With

 'create criteria formula
 With rSrc
    sCritRange1 = .Columns(1).Resize(rowsize:=.Rows.Count - 1).Offset(1, 0).Address
    sCritRange2 = .Columns(6).Resize(rowsize:=.Rows.Count - 1).Offset(1, 0).Address
    rCrit(1).ClearContents
    rCrit(2).Formula = "=countif(" & sCritRange1 & "," & .Cells(2, 1).Address(False, True) & ") > 1"
    rCrit(3).Formula = "=countif(" & sCritRange2 & "," & .Cells(2, 6).Address(False, True) & ") > 1"
End With

'Advanced Filter
wsDup.Cells.Clear
rSrc.AdvancedFilter Action:=xlFilterCopy, criteriarange:=rCrit, copytorange:=rDup

'Clear advanced filter
rCrit.Clear

End Sub

Notez que

• toutes les plages sont qualifiées quant aux feuilles de travail.
  • La source est sur "Sheet1" ; les doublons sont sur "Dup" dans cet exemple.
  • J'ai supposé six colonnes dans la source. Nous pourrions "trouver" la dernière colonne, ou changer cette hypothèse facilement.
• la plage de critères est mise en place et effacée une fois terminée.
• J'ai supposé que tu voulais copier s'il y avait des doublons dans soit colonne A ou colonne F. Si vous souhaitez qu'il y ait des doublons dans les deux, il suffit de modifier la forme de la plage de critères.
• La plage de critères peut être n'importe où ; assurez-vous simplement qu'elle n'interfère pas avec d'autres éléments de votre feuille de calcul Source.
• Le début de la plage de données Source est identifié par la chaîne "Nom d'utilisateur".