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

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

<强>逻辑：

使用Countif检查值是否多次出现。
如果找到多个匹配项，则将行号存储在临时范围内
删除代码末尾的临时范围。我们可以删除循环中的每一行，但这会降低代码的速度。

<强>代码：

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

<强>截图：

enter image description here

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

我在另一个问题中找到了某人的答案并对其进行了一些修改，只需稍微修改以检测基于相似性的重复

全部谢谢！

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

2 个答案: