0

ソースシートからすべての重複レコードを取得して新しいシートに貼り付ける単純なマクロを作成しようとしています。

私はいじり回してきましたが、最も近いのは、クラスター内の最初の重複値を除くすべての重複値を抽出するリストの作成です。たとえば、リストが次のようになっている場合: 1 1 2 3 4 5 1

重複のあるシートがリストされます: 1 1

「1」の最初のインスタンスを一意と見なしますが、それは私が望んでいることではありません。重複した行のすべてのインスタンスを表示したいので、次のようにします: 1 1 1

4

2 に答える 2

0

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
于 2013-04-11T06:00:13.373 に答える