vba - 如何检查 2 列中的重复项并将整行复制到另一张表中？

Question

如果其中任何一个包含重复项，我想检查列 A 和 F 中的重复项，我需要宏将整行复制到同一工作簿中的另一个文件中。


请有人帮我解决这个问题。
下面是我为检查 A 中的重复项而编写的宏，然后将整行复制到名为“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