vba - 查找重复值并移动到不同的工作表

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 's 而不是只有两对(因为两列中只有两对)或保持原样。

我每天要整理大约 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

截图