1

このコードを使用して、重複をシート (dup) に分離します。ここで、シングル/一意のレコードもシート(一意)に分離したいので、1つのワークシートから、一意のレコードと重複の2つのシートがさらに存在します。

Option Explicit 

Sub FindCpy() 
    Dim lw As Long 
    Dim i As Integer 
    Dim sh As Worksheet 

    Set sh = Sheets("Dup") 
    lw = Range("A" & Rows.Count).End(xlUp).Row 

    For i = 1 To lw 'Find duplicates from the list.
        If Application.CountIf(Range("A" & i & ":A" & lw), Range("A" & i).Text) > 1 Then 
            Range("B" & i).Value = 1 
        End If 
    Next i 

    Range("A1:B10000").AutoFilter , Field:=2, Criteria1:=1 
    Range("A2", Range("A65536").End(xlUp)).EntireRow.Copy 
    sh.Range("A65536").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues 
    Selection.AutoFilter 
End Sub
4

1 に答える 1

0

あなたは正しい軌道に乗っています。以下を使用して、一意の値と重複する値を異なるシートにルーティングできます。このコードは、ニーズに合わせて簡単に変更できます (たとえば、複製シートに複製値を 1 回だけ表示するなど)。

Sub RouteUniqueAndDuplicateValues()
    Dim lastRow As Long
    Dim ws As Worksheet
    Dim dupes As Worksheet
    Dim unique As Worksheet
    Dim rng As Range

    Set ws = ThisWorkbook.Sheets("Data")
    Set dupes = ThisWorkbook.Sheets("Dupes")
    Set unique = ThisWorkbook.Sheets("Unique")

    ws.AutoFilterMode = False

    lastRow = ws.Range("A" & ws.Rows.Count).End(xlUp).Row

    ws.Range("B1").Formula = "=COUNTIF(A$1:A$" & lastRow & ", A1)"
    ws.Range("B1").Copy ws.Range("B2:B" & lastRow)

    Set rng = ws.Range("A1:B" & lastRow)
    With rng
        ' find dupes
        .AutoFilter , field:=2, Criteria1:=">1"
        ' copy them to our dupes sheet
        .Offset(1, 0).SpecialCells(xlCellTypeVisible).Copy dupes.Range("A1")
        ' find unique
        .AutoFilter , field:=2, Criteria1:=1
        ' copy them to our unique sheet
        .Offset(1, 0).SpecialCells(xlCellTypeVisible).Copy unique.Range("A1")
    End With
    ws.AutoFilterMode = False

End Sub
于 2013-07-11T19:59:52.883 に答える