Remove multiple duplicates based on corresponding value in another column

[raeannb]

I feel like I'm not clever enough to figure out a solution to my problem this morning (time for more coffee!). Here it is:

I have two columns of data, one with an ID number, and the second with a status code. There are four different possible codes, each with a different priority. When a more complete code is reached, the others are not deleted, so there may be multiple rows belonging to a single ID number. What I'd like to do is have a program delete duplicates according to the priority of their status. For example:

Column1 Column2
1.................D
1.................C
1.................B
2.................D
2.................C
3.................D
3.................D
3.................C
3.................A
4.................D
5.................D
5.................C

So in this case, the patient ID numbers would be in Column 1, numbered 1-5. The status codes would be D, C, B, and A. Code A and B actually have the same priority, and no patient will have both A and B listed (only one or the other).

Ideally, I'd like the code to go through each patient ID and remove every row except the one with the highest priority.

What should I do?

Thank you!!

 

[raeannb]

This is what I have so far, but it's not very clean and I feel like it might be missing some things so I'd love a better way to do it:

'Patient ID is active
'x is the number of rows
For i = 1 To x
If ActiveCell.Value = ActiveCell.Offset(1, 0).Value Then

If ActiveCell.Offset(0, 1) = "A" Or ActiveCell.Offset(0, 1) = "B" Then
ActiveCell.Offset(1, 0).EntireRow.Delete

ElseIf ActiveCell.Offset(1, 1) = "A" Or ActiveCell.Offset(1, 1) = "B" Then
ActiveCell.EntireRow.Delete

ElseIf ActiveCell.Offset(1, 0) = "D" Then ActiveCell.EntireRow.Delete

ElseIf ActiveCell.Offset(1, 1) = "D" Then ActiveCell.Offset(1,0).EntireRow.Delete

Else: ActiveCell.Offset(1, 0).Select

End If

Next i

 

[raeannb]

Argh..the code I just posted only worked for the first two patient IDs...everything else still has duplicates. Help? Thank you!!!

 

[taurean]

Try the following code which has been written by keeping Column A (1,2,3,4 etc) and Column B(a, b, c, d etc) as basis so change them to suit:

Public Sub RemoveLowerDuplicates()
Dim lLastRow As Long
lLastRow = Range("A" & Rows.Count).End(xlUp).Row
For i = lLastRow To 2 Step -1
    If Range("A" & i).Value2 = Range("A" & i - 1).Value2 And _
    Asc(Range("B" & i).Value2) < Asc(Range("B" & i - 1).Value2) Then: Rows(i).Delete
Next i
End Sub

 

[raeannb]

Awesome! Ok so I went with your idea, but I now have all my status labels converted to numbers, instead of the letter system before (so A=1, B=2, C=3, D=4). Just for funsies. Here's what I have:

For i = 1 To x
If Range("A" & i).Value = Range("A" & i - 1).Value And Range("B" & i).Value < Range("B" & i - 1).Value Then*****ERROR
Rows(i).Delete
End If
Next i

Sadly, I'm getting an error I've never seen before at the If statement. The error says "Run-time error '1004': Method 'Range' of object '_Global' failed."

What happened?? I thought for sure it was going to work

 

[taurean]

You have "twisted" the whole logic. The delete procedure will not work as you have done it.

Secondly, When you are at row 1 the (i - 1) will give 0 at Range("A" & i - 1) and thats why the code fails.

And yes, the code doesn't change anything except deleting rows so there's no chance that it will convert it to numerics. This is tested code. If the column layout is Column A and B then please use the code as it is!

 

[raeannb]

So..using your code would have actually required that I change a few things about how I set my program up, but..weirdly I just copied the code and pasted it back it and it worked! Thanks for your help!

A weird note - when you use the Range("A"&i) format and then delete a row based on a condition, the row below the deleted row becomes the i-th row. This means that for every group of duplicates, only half get evaluated! Lameee. I dealt with this by having multiple loops, which is reallllyyy lame. I tweaked it so first it changes the duplicate rows to the color red (instead of deleting them) so I know which rows need to be deleted, in case things get wonky. Then they're deleted in the set of nested loops, and anything that gets missed is still red:

For i = 1 To x
If Range("A" & i + 1).Value = Range("A" & i).Value And Range("B" & i + 1).Value < Range("B" & i).Value Then
Rows(i + 1).Interior.ColorIndex = 3
ElseIf Range("A" & i + 1).Value = Range("A" & i).Value And Range("B" & i + 1).Value = Range("B" & i).Value Then
Rows(i + 1).Interior.ColorIndex = 3
End If
Next i

'Delete red rows
'If red rows exist after running macro, j must be increased.
For j = 1 To 5
For i = 1 To x
If Range("A" & i + 1).Interior.ColorIndex = 3 Then: Rows(i + 1).Delete
Next i
Next j

See the problem? So now if anything is missed, leaving behind red rows at the end, I have to delete them manually (or increase j to clean those up). So far I've only seen a max of 10 duplicates for a given ID, but I don't know what to expect in the future. Does anyone know a way around this? I might have to some day hand this program off to someone else (who knows even less about macros than I do), so having it be fairly self-sufficient would be useful. Thank you!!!!