使用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