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

Excel VBA Macro: Creating a Macro That Extracts Duplicate Record and Pastes into New Sheet

提问by user1599325

I have been trying to create a simple macro that takes all duplicate records from a source sheet and pastes them into a new sheet.

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

I have been messing around, and the closest I've gotten is the creation of a list that extracts all duplicate values except for the first duplicate value in a cluster. So for example, if a list looks like this below: 1 1 2 3 4 5 1

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

The sheet with the duplicates will list: 1 1

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

It will consider the first instance of '1' as unique, and that is totally not what I want. I want it to show every single instance of the duplicated row, so I awnt this: 1 1 1

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

回答by Christian Payne

Here's what I do to deal with duplicates. It isn't a macro, but works for me:

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

1. Sort the column with the duplicate. (For this example, say column C)
2. In a new column, write an IF function. Eg in cell D5: =if(c5=c4,1,"")
3. Copy cell D5 to the entire list.
4. Copy and paste valuecolumn D over itself. Eg in step 2, the formula is replaced with a "1"
5. Sort column D
6. Any row with a 1 is a duplicate. Do as you wish!

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

You can also do things like find the sum of column D (shows me how many duplicates)

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

回答by KacireeSoftware

After clarifications by OP the following procedure will perform as required:

在 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