Question

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. The pic is here.

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

Answer 1

如果您想检查任何的单元格A或单元格F是否在其自己的列中重复，您只需要Or两个条件：

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

另一方面，如果您希望将副本同时列A和F与其他行进行比较，则需要CountIfs

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

最后，Selection.Autofilter语句和代码中的不合格范围（除此之外是正确的）可能会导致一些麻烦。更好地使用合格范围和明确的工作表名称。

修改

通过使用完整列进行匹配，您可以更轻松地使用

'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

使用案例1，并对代码进行一些改进，以便我们使用合格范围，您的代码就像这样，（请仔细阅读评论）：

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

如果你想通过过滤来做到这一点，我建议使用内置了复制方法的高级过滤器。例如：

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

请注意

所有范围都符合工作表的要求。
- 来源是＆＃34; Sheet1＆＃34 ;;副本是＆＃34; Dup＆＃34;在这个例子中
- 我假设源中有六列。我们可以找到＆＃34;最后一栏，或轻松改变这一假设。
完成后设置并清除标准范围。
我认为如果列A 或列F中有重复项，我想要复制。如果您需要在两者中都有重复项，只需更改形状标准范围。
标准范围可以是任何地方;请确保它不会干扰源工作表上的任何其他内容。
源数据范围的开头由字符串＆＃34;用户名＆＃34;

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

2 个答案: