使用VBA删除excel中的非重复数据

Question

我尝试删除非重复数据并保留重复数据 我做了一些编码，但什么也没发生，哦。这是错误。哈哈

这是我的代码。

Sub mukjizat2()
    Dim desc As String
    Dim sapnbr As Variant
    Dim shortDesc As String


    X = 1
    i = 2

    desc = Worksheets("process").Cells(i, 3).Value
    sapnbr = Worksheets("process").Cells(i, 1).Value
    shortDesc = Worksheets("process").Cells(i, 2).Value
    Do While Worksheets("process").Cells(i, 1).Value <> ""

    If desc = Worksheets("process").Cells(i + 1, 3).Value <> Worksheets("process").Cells(i, 3) Or Worksheets("process").Cells(i + 1, 2) <> Worksheets("process").Cells(i, 2) Then
    Delete.EntireRow
    Else
    Worksheets("output").celss(i + 1, 3).Value = desc
    Worksheets("output").Cells(i + 1, 1).Value = sapnbr
    Worksheets("output").Cells(i + 1, 2).Value = shortDesc
    X = X + 1
    End If
    i = i + 1

    Loop


    End Sub

我做错了什么？

我的期望：

before :

sapnbr | ShortDesc | Desc
11     | black hat | black cowboy hat vintage
12     | sunglasses| black sunglasses
13     | Cowboy hat| black cowboy hat vintage
14     | helmet 46 | legendary helmet
15     | v mask    | vandeta mask
16     | helmet 46 | valentino rossi' helmet replica

之后

sapnbr | ShortDesc | Desc
11     | black hat | black cowboy hat vintage
13     | Cowboy hat| black cowboy hat vintage
14     | helmet 46 | legendary helmet
16     | helmet 46 | valentino rossi' helmet replica

---

更新，使用@siddhart 编码，删除唯一值，但不是全部，

http://melegenda.tumblr.com/image/70456675803

Answer 1

就像我在上面的评论中提到的，代码逻辑的主要缺陷是如果数据没有排序就会失败。你需要用不同的逻辑来解决问题

逻辑：

1. 使用Countif 多次检查该值。
2. 将行号存储在临时范围内，以防找到多个匹配项
3. 删除代码末尾的温度范围。我们本可以在循环中删除每一行，但这会减慢您的代码速度。

代码：

Option Explicit

Sub mukjizat2()
    Dim ws As Worksheet
    Dim i As Long, lRow As Long
    Dim delRange As Range

    '~~> This is your sheet
    Set ws = ThisWorkbook.Sheets("process")

    With ws
        '~~> Get the last row which has data in Col A
        lRow = .Range("A" & .Rows.Count).End(xlUp).Row

        '~~> Loop through the rows
        For i = 2 To lRow
            '~~> For for multiple occurances
            If .Cells(i, 2).Value <> "" And .Cells(i, 3).Value <> "" Then
                If Application.WorksheetFunction.CountIf(.Columns(2), .Cells(i, 2)) = 1 And _
                Application.WorksheetFunction.CountIf(.Columns(3), .Cells(i, 3)) = 1 Then
                    '~~> Store thee row in a temp range
                    If delRange Is Nothing Then
                        Set delRange = .Rows(i)
                    Else
                        Set delRange = Union(delRange, .Rows(i))
                    End If
                End If
            End If
        Next
    End With

    '~~> Delete the range
    If Not delRange Is Nothing Then delRange.Delete
End Sub

屏幕截图：

Answer 2

我现在知道问题所在了，呵呵。

sid 给我的代码也检测到重复列间

所以，我的解决方案是，我只是剪切重复项并将其粘贴到其他工作表

Sub hallelujah()

    Dim duplicate(), i As Long
    Dim delrange As Range, cell As Long
    Dim delrange2 As Range

    x = 2

    Set delrange = Range("b1:b30000") 
   Set delrange2 = Range("c1:c30000")

    For cell = 1 To delrange.Cells.Count
        If Application.CountIf(delrange, delrange(cell)) > 1 Then
            ReDim Preserve duplicate(i)
            duplicate(i) = delrange(cell).Address
            i = i + 1
        End If
    Next
    For cell = 1 To delrange2.Cells.Count
    If Application.CountIf(delrange2, delrange2(cell)) > 1 Then
    ReDim Preserve duplicate(i)
    duplicate(i) = delrange(cell).Address
    i = i + 1
    End If
   Next

    For i = UBound(duplicate) To LBound(duplicate) Step -1
        Range(duplicate(i)).EntireRow.Cut
        Sheets("output").Select
        Cells(x, 1).Select
        ActiveSheet.Paste
        Sheets("process").Select
        x = x + 1
    Next i
end sub

我在另一个问题中接受了某人的答案并对其进行了一些修改，只需要再修改一点以根据相似性检测重复

谢谢大家！