Question

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

在我的情况下，例如我在A2，A3＆amp ;; 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

使用VB将重复项从一个工作表剪切并粘贴到另一个工作表

1 个答案: