使用VB剪切和粘贴从一个表到另一个副本

Question

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

在我的情况下，例如，如果我有约翰在A2，A3 & A7我想要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