vba - 重複する値を見つけて別のシートに移動する

Question

以下のように2つの列があります。

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を 2 つのペアだけでなく (両方の列に 2 つのペアしかないため) 移動するか、そのままにしておきます。

1 日あたり約 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

スクリーンショット