Highlight duplicate data blocks

Hi all,


I have a large data sheet made of 8 columns (A:H) and over 45000 rows.
Data are sorted into sets of variable number of rows. Each set of data is separated from the following with one blank row.
I am in need to highlight duplicate data blocks/sets. Duplicate data blocks have to be identical in everything: the number of rows per each set and data content per row and column of that data block.

I spent a long time searching for a similar answered question, but in vain.

Can I get some assistance with this question, please?

More than appreciating ..

M.

Hello mpeterson,

This will highlight duplicate groups on "Sheet1". Change the worksheet name in the code if your worksheet name is different. The macro starts with cell "A1". If you need to start elsewhere, the code will need to be modified a little.

Code:

---

Sub HighlightDupes()


    Dim Data        As Variant
    Dim EndRow      As Long
    Dim LastEntry  As Variant
    Dim MainRng    As Range
    Dim n          As Long
    Dim Rng        As Range
    Dim Row        As Variant
    Dim Text        As String
    Dim Uniques    As New Collection
    Dim Wks        As Worksheet
    Dim xArray      As Variant
   
        Set Wks = ThisWorkbook.Worksheets("Sheet1")
        Set MainRng = Wks.UsedRange
   
        Set LastEntry = MainRng.Find("*", Range("A1"), xlValues, xlWhole, xlByRows, xlPrevious, False, False, False)
        If LastEntry Is Nothing Then Exit Sub
       
        EndRow = LastEntry.Row + 1
       
        Set MainRng = MainRng.Cells(1, 1).Resize(EndRow - MainRng.Row + 1, 8)
        Set Rng = MainRng.CurrentRegion.Resize(, 8)
       
        Do
            DoEvents
           
            Text = ""
           
            For Each Row In Rng.Rows
                ' // Convert 2-D row into 1-D scalar array
                xArray = Application.Transpose(Row.Value)
                xArray = Application.Transpose(x)
       
                ' // Convert arrays to a single string
                Text = Text & Join(xArray, " ")
            Next Row
           
            ' // Create a key for this block
            If Len(Text) > 255 Then
                Text = Left(Text, 255)
            End If
           
            ' // Highlight the group if it is a duplicate
            On Error Resume Next
                Uniques.Add Item:=Rng, Key:=Text
                If Err.Number = 457 Then
                    Rng.Interior.Color = RGB(255, 255, 0)
                End If
            On Error GoTo 0
           
            ' // Get the next block
            Set Rng = Rng.Offset(Rng.Rows.Count + 1, 0)
           
            If Rng.Row >= EndRow Then Exit Do
            Set Rng = Rng.CurrentRegion.Resize(, 8)
        Loop


End Sub

---

Hi Leith,
You don't know how much appreciating I am for your assistance. I actually thought no one would be able to help with such question, so I do thank you for your invaluable assistance.
As I ran the code, it halted with an error message Run-time error 13, Type mismatch. Debugging the error, it highlighted the following line in yellow:

Code:

---

Text = Text & Join(xArray, " ")

---

I hope it would be easy to fix.
Once again thank you very much.

M.

Does this macro do what you want...

Code:

---

Sub HighlightDupes()  Dim X As Long, Z As Long, Groups As Range, Arr1 As Variant, Arr2 As Variant   Set Groups = Columns("A:H").SpecialCells(xlConstants)   For X = 1 To Groups.Areas.Count - 1     Arr1 = Groups.Areas(X)     For Z = X + 1 To Groups.Areas.Count       Arr2 = Groups.Areas(Z)       If Evaluate("IFERROR(SUM(0+(" & Groups.Areas(X).Address & "=" & Groups.Areas(Z).Address & "))=counta(" & Groups.Areas(X).Address & "),FALSE)") Then         Groups.Areas(X).Interior.Color = vbYellow         Groups.Areas(Z).Interior.Color = vbYellow       End If     Next   Next End Sub

---

Yes Rothstein, it does do what I want as exactly as I want it to be.
Honestly, I'm stunned as your code came to me out of the blue. Thank you very much for your precious assistance that came in my dire need.
Please accept my best regards,

M.