Question

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

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

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

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

Answer 1

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

使用副本对列进行排序。（对于这个例子，比如C列）
在新列中，编写IF函数。例如，在单元格D5中：= if（c5 = c4,1，“”）
将单元格D5复制到整个列表。
复制 paste value 列D本身。例如，在步骤2中，将公式替换为“1”
排序栏D
任何带有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

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

2 个答案: