Highlight duplicate data blocks

[mpeterson]

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.

[Leith Ross]

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.



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

[mpeterson]

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:

Text = Text & Join(xArray, " ")
I hope it would be easy to fix.
Once again thank you very much.

M.

[rothstein]

Does this macro do what you want...



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

[mpeterson]

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.