使用VB将副本从一张纸剪切并粘贴到另一张纸上

Question

我在 A 列中有一些数据（名称）。有时某些名称会重复。我正在寻找一个 vb 来剪切所有重复的行并粘贴到另一个表调用重复项。通常，当我在 excel 中使用删除重复功能时，它只会删除所有重复项并留下唯一的名称。

例如，如果我在 A2、A3 和 A7 中有 john 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