Question

我使用此代码将重复项分隔为工作表（dup）。现在我想将单曲/唯一记录也分成单张（唯一），因此从一个工作表中将有两张单独的记录和其他重复记录。

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

Answer 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

复制重复和独特的工作表

1 个答案: