Highlight duplicate rows on the spreadsheet

Apple08

Active Member
Joined
Nov 1, 2014
Messages
450
Hi All

Please I have a spreadsheet with Columns A to AE, I need to find out the duplicate rows if the cells in columns B, C, D and F are matched with another row. I expect those duplicate rows should be highlighted in cell column A (not the whole row) for checking.

The spreadsheet has unknown total number of rows.

Please could anyone give me an idea how to create this macro? Many thanks.
 
Have modified igold's code and you can try the below :

VBA Code:
Sub Find_Duplicates4()

    Dim arr, arr2, rng As Range
    Dim lRow As Long, j As Long, e As Long, i As Long
 
    Application.ScreenUpdating = False
    lRow = Sheets("Project").Cells(Rows.Count, "A").End(xlUp).Row
    Set rng = Range("A2:F" & lRow)
    arr = rng
    arr2 = rng
    For i = 1 To lRow - 1
        For j = 1 To lRow - 1
            If i + 1 > lRow - 1 Then
                Application.ScreenUpdating = True
                MsgBox "Operation Complete"
                Exit Sub
            End If
            If i = j Then j = j + 1
            If arr(i, 2) = arr2(j, 2) And arr(i, 3) = arr2(j, 3) And arr(i, 4) = arr2(j, 4) And arr(i, 6) = arr2(j, 6) Then
                For e = 5 To 1 Step -1
                    If arr(i, e) <> arr2(j, e) Then Exit For
                Next
                rng.Cells(((i - 1) * 5 + i)).Interior.ColorIndex = 6
            End If
        Next
    Next
    Application.ScreenUpdating = True
 
End Sub
Many thanks
Have modified igold's code and you can try the below :

VBA Code:
Sub Find_Duplicates4()

    Dim arr, arr2, rng As Range
    Dim lRow As Long, j As Long, e As Long, i As Long
  
    Application.ScreenUpdating = False
    lRow = Sheets("Project").Cells(Rows.Count, "A").End(xlUp).Row
    Set rng = Range("A2:F" & lRow)
    arr = rng
    arr2 = rng
    For i = 1 To lRow - 1
        For j = 1 To lRow - 1
            If i + 1 > lRow - 1 Then
                Application.ScreenUpdating = True
                MsgBox "Operation Complete"
                Exit Sub
            End If
            If i = j Then j = j + 1
            If arr(i, 2) = arr2(j, 2) And arr(i, 3) = arr2(j, 3) And arr(i, 4) = arr2(j, 4) And arr(i, 6) = arr2(j, 6) Then
                For e = 5 To 1 Step -1
                    If arr(i, e) <> arr2(j, e) Then Exit For
                Next
                rng.Cells(((i - 1) * 5 + i)).Interior.ColorIndex = 6
            End If
        Next
    Next
    Application.ScreenUpdating = True
  
End Sub
Many thanks
Have modified igold's code and you can try the below :

VBA Code:
Sub Find_Duplicates4()

    Dim arr, arr2, rng As Range
    Dim lRow As Long, j As Long, e As Long, i As Long
   
    Application.ScreenUpdating = False
    lRow = Sheets("Project").Cells(Rows.Count, "A").End(xlUp).Row
    Set rng = Range("A2:F" & lRow)
    arr = rng
    arr2 = rng
    For i = 1 To lRow - 1
        For j = 1 To lRow - 1
            If i + 1 > lRow - 1 Then
                Application.ScreenUpdating = True
                MsgBox "Operation Complete"
                Exit Sub
            End If
            If i = j Then j = j + 1
            If arr(i, 2) = arr2(j, 2) And arr(i, 3) = arr2(j, 3) And arr(i, 4) = arr2(j, 4) And arr(i, 6) = arr2(j, 6) Then
                For e = 5 To 1 Step -1
                    If arr(i, e) <> arr2(j, e) Then Exit For
                Next
                rng.Cells(((i - 1) * 5 + i)).Interior.ColorIndex = 6
            End If
        Next
    Next
    Application.ScreenUpdating = True
   
End Sub
Many thanks Sanjeev1976, it works perfectly. Please is it possible to update it only have the duplicate rows highlighted but not both rows?
 
Upvote 0

Excel Facts

Can Excel fill bagel flavors?
You can teach Excel a new custom list. Type the list in cells, File, Options, Advanced, Edit Custom Lists, Import, OK
Here is the code as requested. I see where my mistake was. This code will only highlight one of the duplicates (the first instance). Additionally this code will run about 4x faster than the code submitted by @Sanjeev1976. Around 20 seconds compared to about 80 seconds. The more dupes found the longer both codes will take to run.

VBA Code:
Sub Find_Duplicates4()

    Dim arr, arr2, rng As Range
    Dim lRow As Long, j As Long, e As Long, i As Long, ct As Long
    
    Application.ScreenUpdating = False
    lRow = Sheets("Project").Cells(Rows.Count, "A").End(xlUp).Row
    Set rng = Range("A2:F" & lRow)
    arr = rng
    arr2 = rng
    For i = 1 To lRow - 1
        For j = 1 To lRow - 1
            If i + 1 > lRow - 1 Then
                Application.ScreenUpdating = True
                MsgBox "Operation Complete" & vbNewLine & vbNewLine _
                    & ct & " Duplicates Found"
                Exit Sub
            End If
            If i = j Then j = j + 1
            If arr(i, 6) = arr2(j, 6) Then
                For e = 5 To 1 Step -1
                    If arr(i, e) <> arr2(j, e) Then GoTo NoMatch
                Next
                    rng.Cells(((i - 1) * 5 + i)).Interior.ColorIndex = 6
                    arr(j, 6) = ""
                    ct = ct + 1
                End If
NoMatch:
            Next
    Next
    Application.ScreenUpdating = True
    
End Sub
 
Last edited:
Upvote 0
If you did want to highlight the duplicate (the second instance) of the original (the first instance), this code would do that...

VBA Code:
Sub Find_Duplicates4()

    Dim arr, arr2, rng As Range
    Dim lRow As Long, j As Long, e As Long, i As Long, ct As Long
    
    Application.ScreenUpdating = False
    lRow = Sheets("Project").Cells(Rows.Count, "A").End(xlUp).Row
    Set rng = Range("A2:F" & lRow)
    arr = rng
    arr2 = rng
    For i = UBound(arr) To 1 Step -1
        For j = UBound(arr) To 1 Step -1
            If i = j Then j = j - 1
            If j = 0 Then
                Application.ScreenUpdating = True
                MsgBox "Operation Complete" & vbNewLine & vbNewLine _
                    & ct & " Duplicates Found"
                Exit Sub
            End If
            If arr(i, 6) = arr2(j, 6) Then
                For e = 5 To 1 Step -1
                    If arr(i, e) <> arr2(j, e) Then GoTo NoMatch
                Next
                    rng.Cells(((i - 1) * 5 + i)).Interior.ColorIndex = 6
                    arr(j, 6) = ""
                    ct = ct + 1
                End If
NoMatch:
            Next
    Next
    Application.ScreenUpdating = True
    
End Sub
 
Upvote 0
Solution
If you did want to highlight the duplicate (the second instance) of the original (the first instance), this code would do that...

VBA Code:
Sub Find_Duplicates4()

    Dim arr, arr2, rng As Range
    Dim lRow As Long, j As Long, e As Long, i As Long, ct As Long
   
    Application.ScreenUpdating = False
    lRow = Sheets("Project").Cells(Rows.Count, "A").End(xlUp).Row
    Set rng = Range("A2:F" & lRow)
    arr = rng
    arr2 = rng
    For i = UBound(arr) To 1 Step -1
        For j = UBound(arr) To 1 Step -1
            If i = j Then j = j - 1
            If j = 0 Then
                Application.ScreenUpdating = True
                MsgBox "Operation Complete" & vbNewLine & vbNewLine _
                    & ct & " Duplicates Found"
                Exit Sub
            End If
            If arr(i, 6) = arr2(j, 6) Then
                For e = 5 To 1 Step -1
                    If arr(i, e) <> arr2(j, e) Then GoTo NoMatch
                Next
                    rng.Cells(((i - 1) * 5 + i)).Interior.ColorIndex = 6
                    arr(j, 6) = ""
                    ct = ct + 1
                End If
NoMatch:
            Next
    Next
    Application.ScreenUpdating = True
   
End Sub
Hi igold, a million thanks for your help. They work perfectly. I appreciate it very much for your time and effort, you are amazing!

Thank you to everyone who has contributed to my problem. You are all lovely people! :)
 
Upvote 0
You're welcome. We were all happy to help. Thanks for the feedback.
 
Upvote 0

Forum statistics

Threads
1,213,557
Messages
6,114,291
Members
448,564
Latest member
ED38

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top