delete non duplicate data in excel using VBA

Question

i try to remove non-duplicate data and keep the duplicate data i've done some coding, but nothing happen, oh. it's error. lol

this is my code.

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

what have i done wrong?

what i expect :

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

after

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

---

UPDATE, using coding by @siddhart, the unique value deleted, but not all,

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

Answer 1

Like I mentioned in my comment above, the main flaw in the code logic is that it will fail if the data is not sorted. You need to approach the problem with a different logic

Logic:

1. Use Countif to check of the value occurs more than once.
2. Store the row number in a temp range in case more than one match is found
3. Delete the temp range at the end of the code. We could have deleted each row in a loop but then that will slow down your code.

Code:

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

ScreenShot:

Answer 2

I know the problem now, hehe.

The code that sid gave me also detect the duplication inter-column

So, my solution is, I just cut the duplicates and paste it to other sheet

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

I took someone's answer in another question and modify it a bit, just need to modify little bit more to detect duplication base on similarity

Thanks all!