PDA

View Full Version : Find duplicate cells in a column and contitionally delete the dupes



RKramkowski
01-25-2010, 09:51 AM
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
01-25-2010, 06:52 PM
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
01-26-2010, 10:37 AM
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.


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

ZVI
01-26-2010, 01:33 PM
... 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
01-26-2010, 05:06 PM
Should work now

ZVI
01-26-2010, 05:42 PM
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
02-01-2010, 03:37 PM
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
02-01-2010, 07:06 PM
Requires a blank sheet called Dupes.


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