查找重复值并移至不同的工作表

Question

我有两列如下：

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

我需要一个宏来查找重复对并将它们移动到单独的工作表中，以便当前工作表看起来如此：

4   10
20  50
80  90
100

和表2看起来像这样：

20  20
20  20
70  70
5   5
60  60

我到处搜索，无法找到问题的解决方案。到目前为止我尝试过的所有代码和公式要么移动所有20而不是只移动两对（因为两列中只有两对）或保持原样。

我每天有大约300个条目要进行排序，并且每天都会完全改变。任何有关我的问题的帮助或指导将受到高度赞赏。

我如何达到指示的结果？

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

<强>截图