Delete Row if value in column C is a duplicate

[solidENM]

Hello,
I have a spreadsheet i need to pull data from. Column C has "Alternate ID#s" that sometimes show up multiple times. I need a way to delete each row that has a value in column C represented more than once.

The below code is instant, but retains the first instance. I need every row with a duplicate to be deleted, including the original instance. Any help would be appreciated.
' test3 Macro
'
Dim Cl As Range, Rng As Range

With CreateObject("scripting.dictionary")
For Each Cl In Range("C1", Range("C" & Rows.Count).End(xlUp))
If Not .exists(Cl.Value) Then
.Add Cl.Value, Nothing
Else
If Rng Is Nothing Then Set Rng = Cl Else Set Rng = Union(Rng, Cl)

End If
Next Cl
End With
If Not Rng Is Nothing Then Rng.EntireRow.Delete
'
End Sub

part number	description	alt id
		apple
		apple
		banana
		orange
		pear
		pear
		grapefruit
		raisin
		raisin
		raisin
		tomato
		celery
		banana
		potato
		grape

 

[Joe4]

I would do it like this:

Sub test3()
' test3 Macro
'
Dim Cl As Range, Rng As Range, Del As Range

Set Rng = Range("C1", Range("C" & Rows.Count).End(xlUp))

For Each Cl In Rng
    If Application.WorksheetFunction.CountIf(Rng, Cl) > 1 Then
        If Del Is Nothing Then
            Set Del = Cl
        Else
            Set Del = Union(Del, Cl)
        End If
    End If
Next Cl

If Not Del Is Nothing Then Del.EntireRow.Delete

End Sub

 

[solidENM]

I would do it like this:

Sub test3()
' test3 Macro
'
Dim Cl As Range, Rng As Range, Del As Range

Set Rng = Range("C1", Range("C" & Rows.Count).End(xlUp))

For Each Cl In Rng
    If Application.WorksheetFunction.CountIf(Rng, Cl) > 1 Then
        If Del Is Nothing Then
            Set Del = Cl
        Else
            Set Del = Union(Del, Cl)
        End If
    End If
Next Cl

If Not Del Is Nothing Then Del.EntireRow.Delete

End Sub

that works, but it takes ~50 seconds. I have 24,000 lines on this reference book. Know of any tricks that would make it faster? The original code i posted is near instant. Im not sure why there would be such a large difference when they are both similar in operation. The refence book can be updated automatically on the server, at random. I need this macro to be faster.

Id also be fine with renaming every instance of a duplicate with NA# or something like that.

 

[igold]

Perhaps something like this to change the dupes to NA#

Sub ChangeDupes()

    Dim a As Variant, dic As Object, arr
    Dim lRow As Long, i As Long, x As Long, r As Long
    
    lRow = ActiveSheet.Cells(Rows.Count, 3).End(xlUp).Row
    Set dic = CreateObject("Scripting.Dictionary")
    a = ActiveSheet.Range("C2:C" & lRow)
    ReDim Preserve a(1 To lRow - 1, 1 To 2)
    
    For i = 1 To UBound(a)
        a(i, 2) = 1
        dic(a(i, 1)) = dic(a(i, 1)) + a(i, 2)
    Next
    
    arr = Application.Transpose(dic.keys)
    ReDim Preserve arr(1 To dic.Count, 1 To 2)
    For r = 1 To dic.Count
        arr(r, 2) = dic(arr(r, 1))
    Next
    
    For x = 1 To UBound(a)
        For r = 1 To UBound(arr)
            If arr(r, 2) > 1 Then
                If a(x, 1) = arr(r, 1) Then a(x, 1) = "NA#"
            End If
        Next
    Next

    ActiveSheet.Range("C2").Resize(UBound(a)) = a
  
End Sub

 

[igold]

If you wanted to delete the rows you could make this simple change...

Sub ChangeDupes()

    Dim a As Variant, dic As Object, arr
    Dim lRow As Long, i As Long, x As Long, r As Long
    
    lRow = ActiveSheet.Cells(Rows.Count, 3).End(xlUp).Row
    Set dic = CreateObject("Scripting.Dictionary")
    a = ActiveSheet.Range("C2:C" & lRow)
    ReDim Preserve a(1 To lRow - 1, 1 To 2)
    
    For i = 1 To UBound(a)
        a(i, 2) = 1
        dic(a(i, 1)) = dic(a(i, 1)) + a(i, 2)
    Next
    
    arr = Application.Transpose(dic.keys)
    ReDim Preserve arr(1 To dic.Count, 1 To 2)
    For r = 1 To dic.Count
        arr(r, 2) = dic(arr(r, 1))
    Next
    
    For x = 1 To UBound(a)
        For r = 1 To UBound(arr)
            If arr(r, 2) > 1 Then
                If a(x, 1) = arr(r, 1) Then a(x, 1) = ""
            End If
        Next
    Next

    ActiveSheet.Range("C2").Resize(UBound(a)) = a
    ActiveSheet.Columns("C").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
  
End Sub

 

[solidENM]

If you wanted to delete the rows you could make this simple change...

Sub ChangeDupes()

    Dim a As Variant, dic As Object, arr
    Dim lRow As Long, i As Long, x As Long, r As Long
   
    lRow = ActiveSheet.Cells(Rows.Count, 3).End(xlUp).Row
    Set dic = CreateObject("Scripting.Dictionary")
    a = ActiveSheet.Range("C2:C" & lRow)
    ReDim Preserve a(1 To lRow - 1, 1 To 2)
   
    For i = 1 To UBound(a)
        a(i, 2) = 1
        dic(a(i, 1)) = dic(a(i, 1)) + a(i, 2)
    Next
   
    arr = Application.Transpose(dic.keys)
    ReDim Preserve arr(1 To dic.Count, 1 To 2)
    For r = 1 To dic.Count
        arr(r, 2) = dic(arr(r, 1))
    Next
   
    For x = 1 To UBound(a)
        For r = 1 To UBound(arr)
            If arr(r, 2) > 1 Then
                If a(x, 1) = arr(r, 1) Then a(x, 1) = ""
            End If
        Next
    Next

    ActiveSheet.Range("C2").Resize(UBound(a)) = a
    ActiveSheet.Columns("C").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
 
End Sub

this works great, thanks igold! This one completes in about 13 seconds which is fast enough for me.

Did you create this via the macro recorder? I read through your code and a lot of it is new to me.

 

[igold]

You're welcome. I am happy it works for you. I did not use the recorder. I literally just cobbled it together.

This line is probably what slows the code up tremendously. If you just changed the dupes to NA# (my post #4), I think it would run a lot quicker.

ActiveSheet.Columns("C").SpecialCells(xlCellTypeBlanks).EntireRow.Delete

Thanks for the feedback.

 

[solidENM]

You're welcome. I am happy it works for you. I did not use the recorder. I literally just cobbled it together.

This line is probably what slows the code up tremendously. If you just changed the dupes to NA# (my post #4), I think it would run a lot quicker.

ActiveSheet.Columns("C").SpecialCells(xlCellTypeBlanks).EntireRow.Delete

Thanks for the feedback.

I tried both and they came out to same 13 second run time. Thanks again, i appreciate the help. I have some new terms to google next time i need to put together new code.

 

[igold]

If a code in this thread has worked for you please consider marking it as a solution. Please see Mark as Solution