Вырезать и вставлять дубликаты с одного листа на другой с помощью VB

Question

У меня есть некоторые данные (имена) в столбце A. Бывают случаи, когда некоторые имена дублируются. Я ищу vb, чтобы вырезать все дублированные строки и вставить в другие дубликаты вызовов листа. Обычно, когда я использую функцию delete duplicate в excel, она просто удаляет все дубликаты и оставляет одно уникальное имя.

В моем случае, например, если у меня есть джон самку в A2, A3 & A7 Я хочу В.Б отрезать все 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