code to delete the row if the cells on specific column are unique

Question

What I am trying to achieve is to create a vba code to completely delete the rows if the value in column C (Id) is unique. So in example below the rows 6 and 7 would be dele

Answer 1

I think the most efficient way would be:

1. Initialize an empty HashSet< Integer> (or whatever generic type you want) which will represent all the unique entries of C (id), let's name it uniqueIdSet

2. Iterate through the 2D array

    if(uniqueIdSet.contains(id)){
          //if the id was already seen before, it means it's not unique
          uniqueIdSet.remove(id);
    }
    else{
          //we haven't seen this id yet, add it to the unique set
          uniqueIdSet.add(id);
    }

3. Iterate through the original array again and do:

    if(uniqueSet.contains(id)){
          //if the id is unique, remove it from the array.
          array.remove(currentRow);
    }

Depending on your implementation, you might not be able to remove from the array as you iterate through it. A way around it is initializing a copy of the original array and remove the respective row from there.

Answer 2

The general approach to do do this in a reasonable fast way is to

1. Get your data into a Variant Array
2. Loop the array, identifying unique values
3. Build a range reference to rows to be deleted, but defer the deletion
4. After the loop, delete all rows in one go

---

Sub demo()
    Dim rDel As Range, rng As Range
    Dim dat As Variant
    Dim i As Long, cnt As Long
    Dim TestCol As Long

    ' Avoid magic numbers
    TestCol = 3 ' Column C

    ' Reference the correct sheet
    With ActiveSheet
        ' Get data range
        Set rng = .Range(.Cells(1, TestCol), .Cells(.Rows.Count, TestCol).End(xlUp))

        ' Get data as a Variant Array to speed things up
        dat = rng.Value

        ' Loop the Variant Array
        For i = 2 To UBound(dat, 1)
            ' Is value unique?
            cnt = Application.CountIfs(rng, dat(i, 1))
            If cnt = 1 Then

                ' If so, add to delete range
                If rDel Is Nothing Then
                    Set rDel = .Cells(i, TestCol)
                Else
                    Set rDel = Union(rDel, .Cells(i, TestCol))
                End If
            End If
        Next
    End With

    ' Do the delete
    If Not rDel Is Nothing Then
        rDel.EntireRow.Delete
    End If
End Sub