How to Check for duplicates in 2 columns and copy the entire row into another sheet?

问题

I want to check for the duplicates in columns A & F if either of that contains a duplicate, I need the macro to copy the entire row into another file in the same workbook.

Please someone help me with this. Below is the macro that I have written to check for duplicates in A and then copy the entire row into new sheet named "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

回答1:

If you want to check whether any of cell A or cell F is duplicate in its own column, all you need is to Or the two 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

On the other hand, If you want the duplicate to be by comparing simultaneously columns A and F to other rows, then you will need CountIfs

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

Finally, the Selection.Autofilter statement and the unqualified ranges in the code (which is correct apart of that) might cause some trouble. Better use qualified ranges and explicit sheet names.

EDIT

You can make things easier for you by using full columns for the matching:

'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

Using Case 1, and with some improvement of your code so that we use qualified ranges, your code becomes like this, (please read the comments carefully):

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

回答2:

If you want to do this by filtering, I would suggest using the Advanced Filter which has the copy method built in. For example:

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

Note that

all the ranges are qualified as to worksheets.
- The source is on "Sheet1"; the duplicates are on "Dup" in this example
- I assumed six columns in the source. We could "find" the last column, or change that assumption easily.
the criteria range is set up and cleared when done.
I assumed you wanted to copy if there were duplicates in either column A or column F. If you need there to be duplicates in both, merely change the shape of the criteria range.
The criteria range can be anyplace; just be sure it doesn't interfere with anything else on your Source worksheet.
The start of the Source data range is identified by the string "User Name"

来源：https://stackoverflow.com/questions/44564799/how-to-check-for-duplicates-in-2-columns-and-copy-the-entire-row-into-another-sh

标签

excel

vba

excel-vba