excel - Excel VBA 宏：创建提取重复记录并粘贴到新工作表中的宏

Question

我一直在尝试创建一个简单的宏，它从源工作表中获取所有重复记录并将它们粘贴到新工作表中。

我一直在搞乱，我得到的最接近的是创建一个列表，该列表提取除集群中的第一个重复值之外的所有重复值。例如，如果一个列表如下所示： 1 1 2 3 4 5 1

带有重复项的工作表将列出：1 1

它将认为'1'的第一个实例是唯一的，这完全不是我想要的。我希望它显示重复行的每个实例，所以我喜欢这个：1 1 1

Answer 1

这是我处理重复项的方法。它不是宏，但对我有用：

1. 对具有重复项的列进行排序。（对于这个例子，说 C 列）
2. 在新列中，编写一个 IF 函数。例如在单元格 D5 中： =if(c5=c4,1,"")
3. 将单元格 D5 复制到整个列表。
4. 将值列 D复制并粘贴到自身上。例如在步骤 2 中，公式被替换为“1”
5. 对 D 列进行排序
6. 任何带有 1 的行都是重复的。你爱怎么做就怎么做！

你也可以做一些事情，比如找到 D 列的总和（告诉我有多少重复项）

Answer 2

在 OP 澄清后，将根据需要执行以下程序：

Sub CopyDuplicates()
'***************************************************************
'** This proc expects you to select all the cells in a single **
'** column that you want to check for duplicates in. If dup-  **
'** licates are found, the entire row will be copied to the   **
'** predetermined sheet.                                      **
'***************************************************************

Dim ShO As Worksheet
Dim Rng1 As Range
Dim pRow As Integer
Dim c As Range, cTmp As Range
Dim found
Dim Addresses() As String
Dim a() As String
Dim p2 As Integer
Dim tfFlag As Boolean, sTmp As Variant

Set ShO = Worksheets("Sheet2") 'You can change this to whatever worksheet name you want the duplicates in
Set Rng1 = Application.Selection 'Rng1 is all the currently selected cells
pRow = 1 'This is the first row in our outpur sheet that will be used to record duplicates
ReDim a(0) 'Initialize our array that holds found values

For Each c In Rng1.Cells 'Cycle through each cell in our selected range
ReDim Addresses(0) 'This array holds the cell address for our duplicates.
                   'We will reset the array each time we move to the next cell

'Now check the array of already found duplicates.
'If the current value is already there skip to next value
tfFlag = False
For Each sTmp In a
    If CStr(c.Value) = sTmp Or CStr(c.Value) = "xXDeleteXx" Then 'We've already done this value, move on
        tfFlag = True
        Exit For
    End If
Next

    If Not tfFlag Then 'Remember the flag is true when we have already located the
                       'duplicates for this value, so skip to next value
        With Rng1
            Set found = .Find(c.Value, LookIn:=xlValues) 'Search entire selected range for value
            If Not found Is Nothing Then 'Found it
                Addresses(0) = found.Address 'Record the address we found it
                Do 'Now keep finding occurances of it
                    Set found = .FindNext(found)
                    If found.Address <> Addresses(0) Then
                        ReDim Preserve Addresses(UBound(Addresses) + 1)
                        Addresses(UBound(Addresses)) = found.Address
                    End If
                Loop While Not found Is Nothing And found.Address <> Addresses(0) 'Until we get back to the original address

                If UBound(Addresses) > 0 Then 'We Found Duplicates
                    a(UBound(a)) = c.Value 'Record the value we found a duplicate for in an array
                    ReDim Preserve a(UBound(a) + 1) 'add an empty spot to the array for next value

                    ShO.Range("A" & pRow).Value = "Duplicate Rows for Value " & c.Value & _
                              " in Column " & c.Column & " on original sheet" 'Add a label row
                    pRow = pRow + 1 'Increment to the next row
                    For p2 = UBound(Addresses) To 0 Step -1 'Cycle through the duplicate addresses
                        Set cTmp = Rng1.Worksheet.Range(Addresses(p2)) 'we just want to easily get the correct row to copy
                        Rng1.Worksheet.Rows(cTmp.Row).Copy ShO.Rows(pRow) 'Copy form orig to duplicates sheet
                            cTmp.Value = "xXDeleteXx" 'Mark for Delete the original row
                        pRow = pRow + 1 'Increment row counter
                    Next p2
                    pRow = pRow + 1 'This increment will give us a blank row between sets of dupicates
                End If
            End If
        End With
    End If
Next
'Now go delete all the marked rows

Do
tfFlag = False
For Each c In Rng1
    If c.Value = "xXDeleteXx" Then
        Rng1.Worksheet.Rows(c.Row).Delete (xlShiftUp)
        tfFlag = True
    End If
Next
Loop Until tfFlag = False

End
End Sub