vba 查找重复值并移动到不同的工作表
声明：本页面是StackOverFlow热门问题的中英对照翻译，遵循CC BY-SA 4.0协议，如果您需要使用它，必须同样遵循CC BY-SA许可，注明原文地址和作者信息，同时你必须将它归于原作者（不是我）：StackOverFlow
原文地址: http://stackoverflow.com/questions/14278314/
Warning: these are provided under cc-by-sa 4.0 license. You are free to use/share it, But you must attribute it to the original authors (not me):
StackOverFlow
Find duplicate values and move to different sheet
提问by user1955214
I have two columns as below:
我有两列如下：
4 10
20 5
20 20
70 20
60 50
80 70
5 90
20 60
100
I need a macro to find the duplicate pairs and move them to a separate sheet so the current sheet looks so:
我需要一个宏来查找重复的对并将它们移动到单独的工作表中，以便当前工作表看起来如此：
4 10
20 50
80 90
100
and sheet 2 looks like this:
表 2 如下所示：
20 20
20 20
70 70
5 5
60 60
I have searched everywhere and cannot find a solution to my problem. All the codes and formulae I've tried so far either move all the 20's instead of just two pairs of them (as there are only two pairs in both columns) or leave them as is.
我到处搜索，但找不到解决我的问题的方法。到目前为止，我尝试过的所有代码和公式要么移动所有的20' 而不是仅移动两对（因为两列中只有两对），要么保持原样。
I have about 300 entries per day to sort through and it changes completely on a daily basis. Any help or guidance on my problem will be highly appreciated.
我每天大约有 300 个条目要整理，而且每天都在变化。对我的问题的任何帮助或指导将不胜感激。
How can I achieve the result indicated?
我怎样才能达到指示的结果？
回答by Siddharth Rout
There are many ways to do it. Here is one example.
有很多方法可以做到。这是一个例子。
Try this. I have commented the code so you will not have a problem understanding it.
尝试这个。我已经注释了代码，所以你理解它不会有问题。
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
Screenshot
截屏
