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

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

请有人帮我这个。 下面是我写的macros来检查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 ie 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

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

 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 

注意

• 所有的范围都符合工作表的要求。
  • 源文件在“Sheet1”上; 在这个例子中重复的是“Dup”
  • 我假设来源有六栏。 我们可以“find”最后一列，或轻松改变这个假设。
• 标准范围设置完成后清除。
• 如果在列A 或列F中有重复项，我认为你想复制。如果你需要在这两个项中有重复项，只要改变标准范围的形状即可。
• 标准范围可以是任何地方; 只要确保它不会干扰源工作表上的其他任何内容。
• 源数据范围的开始由string“用户名”