Deleting Duplicate Rows with a Catch

[herpasymplex10]

I've seen this topic very often and did a lot of searching on previous threads but did not find a solution to my situation.

I would like a macro that could hopefully do the following.

Look at all the rows in my worksheet
and delete duplicate rows in certain situations.

If Row 117, 118, and 119 are all identical,
it would delete all but on of them.

The catch is row 502 may be the same as all of the above
but I don't want it deleted. Only if consecutive rows are duplicates
should the macro delete all but one.

Anyone have any ideas?

Thanks,
Christian

 

[Carly]

How about trying something like this? This test is just checking the values in column A to see if they match but you can change this to wherever your data is the same.

Sub test()
Range("A1").End(xlDown).Select
Do While Not ActiveCell.Row = 1
    If ActiveCell.Offset(1, 0).Value <> ActiveCell.Value Then
        ActiveCell.Offset(-1, 0).Select
    Else
        ActiveCell.EntireRow.Delete
        ActiveCell.Offset(-1, 0).Select
    End If
Loop
    If ActiveCell.Offset(1, 0).Value <> ActiveCell.Value Then
        ActiveCell.Offset(-1, 0).Select
    Else
        ActiveCell.EntireRow.Delete
    End If
End Sub

 

[herpasymplex10]

How about trying something like this? This test is just checking the values in column A to see if they match but you can change this to wherever your data is the same.

Sub test()
Range("A1").End(xlDown).Select
Do While Not ActiveCell.Row = 1
    If ActiveCell.Offset(1, 0).Value <> ActiveCell.Value Then
        ActiveCell.Offset(-1, 0).Select
    Else
        ActiveCell.EntireRow.Delete
        ActiveCell.Offset(-1, 0).Select
    End If
Loop
    If ActiveCell.Offset(1, 0).Value <> ActiveCell.Value Then
        ActiveCell.Offset(-1, 0).Select
    Else
        ActiveCell.EntireRow.Delete
    End If
End Sub

Hmmm. I'm getting an error

"Run time error '1004':
Application defined or object defined error:

pointing here

ActiveCell.Offset(-1, 0).Select

 

[Carly]

maybe try

Range("A1").End(xlDown).Select 
Do While Not ActiveCell.Row = 1 
    If ActiveCell.Offset(1, 0).Value <> ActiveCell.Value Then 
        ActiveCell.Offset(-1, 0).Select 
    Else 
        ActiveCell.EntireRow.Delete 
        ActiveCell.Offset(-1, 0).Select 
    End If 
Loop 
    If ActiveCell.Offset(1, 0).Value = ActiveCell.Value Then 
        ActiveCell.EntireRow.Delete 
    End If 
End Sub

 

[Peter_SSs]

Christian

Note that in most cases when using code you do not have to actually select cells to work with them. The code will run much faster if you avoid selecting. Here is my suggested code. It also assumes the data is in column A (column 1).

<font face=Courier New><SPAN style="color:#00007F">Sub</SPAN> DeleteRows()
    <SPAN style="color:#00007F">Dim</SPAN> lr <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Long</SPAN>
    <SPAN style="color:#00007F">Dim</SPAN> r <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Long</SPAN>
    
    Application.ScreenUpdating = <SPAN style="color:#00007F">False</SPAN>
    lr = Cells(Rows.Count, 1).End(xlUp).Row
    <SPAN style="color:#00007F">For</SPAN> r = lr <SPAN style="color:#00007F">To</SPAN> 2 <SPAN style="color:#00007F">Step</SPAN> -1
        <SPAN style="color:#00007F">If</SPAN> Cells(r, 1).Value = Cells(r - 1, 1).Value <SPAN style="color:#00007F">Then</SPAN>
            Rows(r).EntireRow.Delete
        <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">If</SPAN>
    <SPAN style="color:#00007F">Next</SPAN> r
    Application.ScreenUpdating = <SPAN style="color:#00007F">True</SPAN>
<SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">Sub</SPAN></FONT>