使用VB剪切和粘贴从一张到另一张重复

我在A列有一些数据（名称）。有些时候有些名字会被复制。 我正在寻找一个vb剪切所有重复的行，并粘贴到另一个表呼叫重复。 通常，当我在Excel中使用删除重复函数时，只删除所有重复项并保留唯一的名称。

在我的情况下，例如，如果我有约翰在A2，A3和A7 doe我想vb剪切所有3行（A2，A3和A7），并粘贴到另一张表。

提前致谢

Answer 1

像这样的东西？

Sub removedup() Dim x As Integer Dim unique() As String ReDim unique(0) Dim dups() As String ReDim dups(0) Dim dupFlag As Boolean Dim dupCount As Integer Dim rowcount As Integer Dim sheet2indexer As Integer 'get array of all unique names dupFlag = False x = 1 Do While Sheets(1).Cells(x, 1).Value <> "" For y = 0 To UBound(unique) If Sheets(1).Cells(x, 1).Value = unique(y) Then dupFlag = True End If Next y If dupFlag = False Then ReDim Preserve unique(UBound(unique) + 1) unique(UBound(unique)) = Sheets(1).Cells(x, 1).Value Else dupFlag = False End If x = x + 1 Loop rowcount = x - 1 'unique(1 to unbound(unique)) now contains one of each entry 'check which values are duplicates, and record dupCount = 0 For y = 1 To UBound(unique) x = 1 Do While Sheets(1).Cells(x, 1).Value <> "" If unique(y) = Sheets(1).Cells(x, 1).Value Then dupCount = dupCount + 1 End If x = x + 1 Loop If dupCount > 1 Then 'unique(y) is found more than once ReDim Preserve dups(UBound(dups) + 1) dups(UBound(dups)) = unique(y) End If dupCount = 0 Next y sheet2indexer = 0 'now we have a list of all duplicate entries, time to start moving rows For z = rowcount To 1 Step -1 For y = 1 To UBound(dups) If Sheets(1).Cells(z, 1).Value = dups(y) Then 'current row z is a duplicate sheet2indexer = sheet2indexer + 1 Sheets(1).Rows(z).Cut Sheets(2).Rows(sheet2indexer) Sheets(1).Rows(z).Delete End If Next y Next z End Sub