Find duplicate cells in a column and contitionally delete the dupes

[RKramkowski]

Hi,

I have a large spreadsheet that has several columns. Only one column (C)has duplicate values that I care about - the remaining columns may be all different or may have duplicates. I've presorted so the duplicate values are together. Where there are duplicates in column C, I want to delete all duplicates (entire row) where column D contains the text "unknown". When duplicates are grouped, those with "unknown' in column D could be in any sequence. For example it I find three rows with duplicates in column C, "Unknown" could be the first, second, third, or any combination thereof (all three have "unknown" or any two have "unknown". To complicate it further, if all entries in column D are "unknown", I want to keep the first one. Probably the "before and after" examples will help...The "before" and "after" are two separate tabs for example only. I don't need the data saved in a new tab.

Thanks,
Bob

[ZVI]

Hi Bob,
Try this code:

' ZVI:2010_01_26 vbaexpress.com/forum/showthread.php?t=30335
Sub DelCondDups()
  
  ' Purpose value (upper case) to be deleted
  Const X = "UNKNOWN"
  
  Dim Rng As Range, Arr(), r&, rs&, i&, k$, p$
  
  ' Set working range
  With ActiveSheet.Range("A1:D1").CurrentRegion
    Set Rng = .Resize(, 4)
    rs = .Rows.Count
  End With
  If rs < 2 Then Exit Sub
  
  ' Empty the non unique values of DevName, taking into account Location values
  With CreateObject("Scripting.Dictionary")
    .CompareMode = 1
    Arr() = Rng.Value
    For r = 2 To rs
      k = Arr(r, 3)
      p = Arr(r, 4)
      If .Exists(k) Then
        i = .Item(k)
        If UCase(p) <> X And UCase(Arr(i, 4)) = X Then
          Arr(i, 3) = Empty
          .Item(k) = r
        Else
          Arr(r, 3) = Empty
        End If
      Else
        .Item(k) = r
      End If
    Next
    i = .Count + 1
  End With
  
  ' Delete rows with empty values in DevName column
  If i < rs Then
    Rng.Value = Arr()
    With Rng
      .Sort .Cells(1, 3), 1, Header:=xlYes
      .Rows(1).Resize(rs - i).Offset(i).Clear
    End With
  End If
  
End Sub

Regards,
Vladimir

[mbarron]

I don't know what happened to yesterday's reply (or xld's from yesterday either) but here it is again - but a little different.

[vba]
Sub delDupes()

Dim i As Long, j As Long, iDupe As Integer
i = 1

Do Until Cells(i, 4) = ""
iDupe = Application.CountIf(Range("C:C"), Cells(i, 3))
If iDupe = 1 Then
i = i + 1
Else
If iDupe = Application.CountIf(Range(Cells(i, 4), Cells(i + iDupe - 1)), "Unknown") Then
Range(Cells(i + 1, 4), Cells(i + iDupe - 1)).EntireRow.Delete
Else
For j = i To i + iDupe - 1
If Cells(j, 4) = "Unknown" Then
Cells(j, 4).EntireRow.Delete
End If
Next
End If
End If

Loop

End Sub[/vba]

[ZVI]

... a little different.

Seems that the result of your code is little different to the one in Sheet "After" of OP’s example.
Sorry for this message - it's just for increasing of my posts account because I can’t publish the links in any posts as to my poor activity level.

[mbarron]

Should work now

[ZVI]

Should work now

Yea, it works properly now! And your code is much clearer and simpler.
Mine makes sense only on large range taking into account its speed.

[RKramkowski]

Thanks for the reply. It worked but now I've been thrown another wrinkle... rather than delete the duplicates, I need to preserve all the rows but move them to another tab. As before, the duplicates will be together. So the sequence is:

1. Find the duplicate cells (as before)
2. Copy the entire row for all duplicate values to another tab (I need all the duplicate rows, not just those to be deleted).
3. Do the conditional delete as before.

I find many posts on how to delete a dupe but none on how to copy or move the duplicates to another tab.


Thanks,
Bob

[mbarron]

Requires a blank sheet called Dupes.

[VBA]
Sub delDupes()

Dim i As Long, j As Long, iDupe As Integer
i = 1
Cells(1, 1).EntireRow.Copy Destination:=Worksheets("Dupes").Cells(1.1)
Do Until Cells(i, 4) = ""
iDupe = Application.CountIf(Range("C:C"), Cells(i, 3))
If iDupe = 1 Then
i = i + 1
Else
Range(Cells(i, 1), Cells(i + iDupe - 1, 1)).EntireRow.Copy _
Destination:=Worksheets("Dupes").Cells(Rows.Count, 1).End(xlUp).Offset(1)
If iDupe = Application.CountIf(Range(Cells(i, 4), Cells(i + iDupe - 1)), "Unknown") Then
Range(Cells(i + 1, 4), Cells(i + iDupe - 1)).EntireRow.Delete
Else
For j = i To i + iDupe - 1
If Cells(j, 4) = "Unknown" Then
Cells(j, 4).EntireRow.Delete
End If
Next
End If
End If

Loop

End Sub[/VBA]