查找重复的值并移至其他表单

我有两列如下：

4 10 20 5 20 20 70 20 60 50 80 70 5 90 20 60 100 

我需要一个macros来find重复对，并将它们移动到一个单独的工作表，所以当前工作表看起来如此：

 4 10 20 50 80 90 100 

和工作表2看起来像这样：

 20 20 20 20 70 70 5 5 60 60 

我到处search，找不到解决我的问题。 我试过的所有的代码和公式，或者移动了所有的20 ，而不是只有两对（因为在这两列中只有两对），或者保持原样。

我每天大约有300个条目可以进行sorting，并且每天都会完全改变。 任何帮助或指导我的问题将不胜感激。

我怎样才能达到结果？

Answer 1

有很多方法可以做到这一点。 这是一个例子。

尝试这个。 我已经评论了代码，所以你不会理解它的问题。

 Option Explicit Sub Sample() Dim wsMain As Worksheet, wsOutput As Worksheet Dim lRowColA As Long, lRowColB As Long, i As Long, j As Long Dim aCell As Range, ColARng As Range, ColBRng As Range '~~> Set input Sheet and output sheet Set wsMain = ThisWorkbook.Sheets("Sheet1") Set wsOutput = ThisWorkbook.Sheets("Sheet2") '~~> Start Row in output sheet j = 1 With wsMain '~~> Get last row in Col A & B lRowColA = .Range("A" & .Rows.Count).End(xlUp).Row lRowColB = .Range("B" & .Rows.Count).End(xlUp).Row '~~> Set your actual data range in Col A and B Set ColARng = .Range("A1:A" & lRowColA) Set ColBRng = .Range("B1:B" & lRowColB) '~~> Loop through Col A For i = 1 To lRowColA If Len(Trim(.Range("A" & i).Value)) <> 0 Then '~~> Check if there are duplicates of Col A value in Col B If Application.WorksheetFunction.CountIf(ColBRng, _ .Range("A" & i).Value) > 0 Then '~~> If found write to output sheet wsOutput.Cells(j, 1).Value = .Range("A" & i).Value wsOutput.Cells(j, 2).Value = .Range("A" & i).Value '~~> Find the duplicate value in Col B Set aCell = ColBRng.Find(What:=.Range("A" & i).Value, _ LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, _ SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False) '~~> Clear the duplicate value in Col B aCell.ClearContents '~~> Clear the duplicate value in Col A .Range("A" & i).ClearContents '~~> Set i = 1 to restart loop and increment '~~> the next row for output sheet i = 1: j = j + 1 End If End If Next i '~~> Sort data in Col A to remove the blank spaces ColARng.Sort Key1:=.Range("A1"), Order1:=xlAscending, Header:=xlNo, _ OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _ DataOption1:=xlSortNormal '~~> Sort data in Col B to remove the blank spaces ColBRng.Sort Key1:=.Range("B1"), Order1:=xlAscending, Header:=xlNo, _ OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _ DataOption1:=xlSortNormal End With End Sub 

截图