Macro To Find Rows With Duplicates, Compare Cells, And Delete Rows. - Excel

Hi,

I will appreciate your help on my project. As shown in the attached file, I have data from Columns A to G. I want to do the following:

1. Look for duplicates in all column A
2. For each duplicate found in column A, check if all values in columns B, C and D are also duplicates (The condition is all 4 columns must have the same values)
3. If the condition in (2) is satisfied, compare column E for all the rows; select the row with the minimum value in column E, and delete the other rows.

For example:

A B C D E F G

Row1:Test01 100 Class 1 1 80.67 6.47 145
Row2:Test01 50 Class 1 3 80.25 6.71 598
Row3:Test01 100 Class 1 1 77.72 6.62 110

Since Rows 1 and 3 have the same values in columns A, B, C and D; and Row3 value in column E is less than Row1 value (77.72<80.67); Delete Row1

Results

A B C D E F G

Row2:Test01 50 Class 1 3 80.25 6.71 598
Row3:Test01 100 Class 1 1 77.72 6.62 110

Thank you for your help!

I think I captured everything. The reason I had it do 2 loops was because of the random potential for deletions. I figured this way the deletion wouldn't mess up the loop.

Sub RunMe()
Dim ws As Worksheet:    Set ws = Sheets("Sheet1")
Dim icell As Long, LR As Long, rCell As Long
Dim c As Range, myRange As Range
Dim firstAddress

Application.ScreenUpdating = False
LR = ws.Range("A" & Rows.Count).End(xlUp).Row

For icell = LR To 1 Step -1
    Set myRange = ws.Range("D" & icell)
    With ws.Range("D1:D" & LR)
        Set c = .Find(myRange.Value, LookIn:=xlValues, LookAt:=xlWhole)
        If Not c Is Nothing Then
            firstAddress = c.Address
            Do
                If c.Address <> myRange.Address Then
                    If c.Offset(, -1).Value = myRange.Offset(, -1).Value And c.Offset(, -2).Value = myRange.Offset(, -2).Value And c.Offset(, -3).Value = myRange.Offset(, -3).Value Then
                        If c.Offset(, 1).Value > myRange.Offset(, 1).Value Then
                            c.Interior.ColorIndex = 3
                        Else
                            myRange.Interior.ColorIndex = 3
                        End If
                    End If
                End If
                Set c = .FindNext(c)
            Loop While Not c Is Nothing And c.Address <> firstAddress
        End If
    End With
Next icell

For rCell = LR To 1 Step -1
    If ws.Range("D" & rCell).Interior.ColorIndex = 3 Then
        ws.Range("D" & rCell).EntireRow.Delete Shift:=xlUp
    End If
Next rCell

Application.ScreenUpdating = True

End Sub

Thank you for the quick response. I works like magic. I will spend some time to understand the code.

Thanks!

I have finished running the code and it works perfect. I have a little concern though. Instead of deleting the entire row, can it be modified to delete only the data? I have some other data on the worksheet that I dont want to delete

Thanks

Thats an easy one.

Change:

For rCell = LR To 1 Step -1
    If ws.Range("D" & rCell).Interior.ColorIndex = 3 Then
        ws.Range("D" & rCell).EntireRow.Delete Shift:=xlUp
    End If
Next rCell

to this:

For rCell = LR To 1 Step -1
    If ws.Range("D" & rCell).Interior.ColorIndex = 3 Then
        ws.Range("D" & rCell).Interior.ColorIndex = xlNone
        ws.Range("D" & rCell).ClearContents   
End If
Next rCell

Note: it would have been best to just do this within the first loop and disregard the second loop. However I don't want to take the time to go back and error check the first loop.