Sub 
Application.ScreenUpdating = False 
R1 = Selection.Cells(1).Row 
K1 = Selection.Cells(1).Column 
RL = Selection.Cells(Selection.Cells.Count).Row 
KL = Selection.Cells(Selection.Cells.Count).Column 
CC = Selection.Columns.Count 
If R1 = RL Then 
MsgBox "Select atleast two rows!" 
Exit Sub 
End If 
RDupe = 0 
For j = R1 To RL 
Duplicate = 0 
For i = K1 To KL 
If j > R1 Then 
If Cells(j, i).Value = Cells(j - 1, i).Value Then 
Duplicate = Duplicate + 1 
End If 
End If 
Next 
If Duplicate = CC Then 
Range(Cells(j, K1), Cells(j, K1 + CC - 1)).Select 
Selection.Font.ColorIndex = 3 
Range(Cells(j - 1, K1), Cells(j - 1, K1 + CC - 1)).Select 
Selection.Font.ColorIndex = 3 
RDupe = RDupe + 1 
End If 
Next 
Application.ScreenUpdating = True 
Range(Cells(R1, K1), Cells(RL, KL)).Select 
'If RDupe > 0 Then MsgBox Trim(Str(RDupe)) & " Rows!" 
End Sub