PDA

View Full Version : Find Duplicates and Highlight Row in Red



trevor2524
07-24-2013, 05:23 PM
I'm trying to figure out a way for a macro to search row by row. It will check columns C, D, and E to see if the row below it has the same values. If row 2 has the same values as row 1 then it will check columns a and b in row 2 to see if it is empty. If it is empty then the entire row 1 will be highlighted in red and row 2 will be deleted. This macro will continue until the program finds 4 empty rows in a row. Any help is greatly appreciated.

SamT
07-24-2013, 05:42 PM
When you say
This macro will continue until the program finds 4 empty rows in a row do you mean 4 entire rows, 4 column A & B Rows or 4 Columns C,D, & E Rows?

trevor2524
07-24-2013, 05:55 PM
4 empty rows for C,D, and E.

Teeroy
07-24-2013, 11:50 PM
Try the following code and see if it helps you.



Sub Kill_Dups()
Dim count As Integer, rTest As Range
ActiveSheet.UsedRange.EntireRow.Interior.ColorIndex = xlNone
For Each rTest In Intersect(ActiveSheet.UsedRange, Columns("C"))
If rTest = rTest.Offset(1, 0) And rTest.Offset(0, 1) = rTest.Offset(1, 1) And _
rTest.Offset(0, 0) = rTest.Offset(1, 0) Then
If WorksheetFunction.CountBlank(rTest.Resize(1, 3)) = 3 Then
count = count + 1
Else
rTest.EntireRow.Interior.ColorIndex = 3
rTest.Offset(1, 0).EntireRow.Delete
count = 0
End If
End If
If count = 4 Then Exit Sub
Next
End Sub

SamT
07-25-2013, 04:25 AM
Sub SamT()
Dim Cel As Range
Dim BCel As Range
ActiveSheet.UsedRange.Interior.ColorIndex = xlNone

'Go down Column "C" cell by cell
For Each Cel In Range("C:C")

'Check if 4 empty rows (C,D,&E)
Set BCel = Cel 'Don't want to resize Cel, since we need to use it as one cell.
If WorksheetFunction.CountBlank(BCel.Resize(4, 3)) = 12 Then Exit Sub

'Check if this Row(C,D,&E) is empty then Skip testing
If Trim(Cel.Text & Cel.Offset(0, 1).Text & Cel.Offset(0, 2).Text) = "" _
Then GoTo CellNext 'and skip testing

'Test for dupes
If Cel = Cel.Offset(1, 0) _
And Cel.Offset(0, 1) = Cel.Offset(1, 1) _
And Cel.Offset(0, 2) = Cel.Offset(1, 2) Then
'Test A&B for blanks
If Cel.Offset(1, -2).Text & Cel.Offset(1, -1).Text = "" Then
Cel.EntireRow.Interior.ColorIndex = 3
Cel.Offset(1, 0).EntireRow.Delete
End If
End If

CellNext:
Next Cel
End Sub