Find Duplicates and Highlight Row in Red

[trevor2524]

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]

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]

4 empty rows for C,D, and E.

[Teeroy]

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]

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