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

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

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

包含副本的工作表将列出： 1. 一,

它会把“1”的第一个例子看作是独一无二的，这完全不是我想要的。我希望它显示复制行的每个实例，因此我得出以下结论： 1. 1.

---

1

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

使用重复项对列进行排序。（对于本例，假设为C列）

在新列中，编写一个IF函数。单元格D5中的Eg:=if（c5=c4,1，“”）

将单元格D5复制到整个列表中

将D列复制到其自身上。例如，在步骤2中，公式被替换为“1”

排序列D

任何带有1的行都是重复的。随你的便

---

您还可以做一些事情，如查找D列的总和（显示有多少个副本）

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

子副本（）
'***************************************************************
“**此过程要求您在一个单元格中选择所有单元格**
“**要在其中检查重复项的列。如果dup-**
“**如果找到副本，则整行将复制到**
“**预定页**
'***************************************************************
Dim ShO As工作表
变暗Rng1 As范围
Dim船头为整数
尺寸c作为范围，cTmp作为范围
暗淡的发现
Dim Addresses（）作为字符串
将（）变暗为字符串
将p2设置为整数
Dim tfFlag为布尔值，sTmp为变量
Set ShO=Worksheets（“Sheet2”）“您可以将其更改为希望复制的任何工作表名称
设置Rng1=应用程序。选择“Rng1”是当前选定的所有单元格
pRow=1'这是输出表中用于记录重复项的第一行
重拨a（0）'初始化包含找到的值的数组
对于Rng1中的每个c。细胞在我们所选范围内通过每个细胞的周期
ReDim Addresses（0）'此数组保存重复项的单元格地址。
'我们将在每次移动到下一个单元格时重置阵列
'现在检查已找到重复项的数组。
'如果当前值已存在，则跳到下一个值
tfFlag=False
对于中的每个sTmp
如果CStr（c.Value）=sTmp或CStr（c.Value）=“xXDeleteXx”，则“我们已经完成了此值，请继续
tfFlag=True
退出
如果结束
下一个
如果不是tfFlag，则“记住，当我们已经找到
'此值重复，因此跳到下一个值
使用Rng1
Set found=.Find（c.Value，LookIn:=xlValues）'在整个选定范围内搜索值
如果找不到什么，那么“找到了”
地址（0）=找到。地址'记录我们找到它的地址
现在要继续寻找它的发生
Set found=.FindNext（已找到）
如果找到。地址（0），则
重拨保留地址（UBound（地址）+1）
地址（UBound（Addresses））=已找到。地址
如果结束
未找到时的循环为Nothing并已找到。地址（0）“”直到返回到原始地址
如果UBound（Addresses）>0，则“我们发现了重复项”
a（UBound（a））=c.Value'记录我们在数组中找到的重复值
ReDim Preserve a（UBound（a）+1）'在数组中添加一个空位以获得下一个值
ShO.Range（“A”和pRow.Value=“值重复行”和c.Value&_
“在列中”&c.列和“在原始工作表上”'添加标签行
船头=船头+1'增量到下一行
对于p2=UBound（地址）到0，步骤-1'在重复地址之间循环
设置cTmp=Rng1.Worksheet.Range（Addresses（p2））'我们只想轻松获得要复制的正确行
Rng1.工作表行（cTmp.Row）.复制车间行（船头）'将表格原件复制到副本工作表
cTmp.Value=“xXDeleteXx”'标记删除原始行
船首=船首+1'增量行计数器
下一个p2
船头=船头+1'此增量将在两组复制之间为我们提供一个空白行
如果结束
如果结束
以
如果结束
下一个
'现在删除所有标记行
做
tfFlag=False
对于Rng1中的每个c
如果c.Value=“xXDeleteXx”，则
Rng1.Worksheet.Rows（c.Row）.Delete（xlShiftUp）
tfFlag=True
如果结束
下一个
循环直到tfFlag=False
终点
端接头

@Christian Payne回答得很好。但如果你真的需要一个宏，你可以做一些类似的事情，但你需要逆转它-在那里，我删除了所有重复的项目，你需要保留它们。因此，您将不删除它们，而是将它们粘贴到工作表中。在包含列表的单元格上迭代，将Unique添加到集合或脚本字典中，存储该项及其出现次数。然后对项目进行迭代，并循环在下一张表上按顺序打印出发生的次数。嗨，Christian，我目前正在运行一个类似的过程，并在一个团队中工作，该团队必须在数千条记录上运行它。有时它会变得资源密集型，正因为如此，我正在寻找一个宏。不过我真的很感激！嗨，卡西里，谢谢你的回复。我测试了宏，并列出了两个类似的填充：1$A$2$A$3$A$4$A$5$A$6$A$1。我真的想要它