Find duplicate rows of multiple cells...

[spacely]

Hi ...

I have a rectangular arrangement of cells, and want to detect if any row has the same entries as any other row, in the range of rows of interest. A trigger at the end of the duplicate rows, or a conditional format to display which are copies of each other would be great.

So:

1 3 6 4 3 2 1 3
4 5 6 7 3 2 1 4
6 7 8 1 0 8 7 6
4 5 6 7 3 2 1 4

..would flag as row 2 and 4 being identical.

Thanks!

 

[JumpingCrab]

Interesting question.
If you just need to get rid of the duplicates, you could use Data>Remove Duplicates, but that is a bit brute force I guess. It does eliminate duplicate rows nicely.

A way to mark the duplicate lines could be to concatenate each row into a single string, hash the string and the use conditional formatting to highlight the duplicate hashes.
There is a nice VBA hash implementation to be found here.
I added a wrapper function as a UDF, so you can use it on a range of cells.

The code below could work.

Just use =HASH(A1:A8) in cell A9. You can create longer hashes by tweaking the cutoff value (I used 7)

Option Explicit

Public Function Hash(ByVal Rng As Range)

    Dim stringToHash As String
    Dim cl As Range
    
    For Each cl In Rng
        stringToHash = stringToHash & Format(cl)
    Next
    Hash = BASE64SHA1(stringToHash)
    
End Function

Public Function BASE64SHA1(ByVal sTextToHash As String)

    Dim asc As Object
    Dim enc As Object
    Dim TextToHash() As Byte
    Dim SharedSecretKey() As Byte
    Dim bytes() As Byte
    Const cutoff As Integer = 7

    Set asc = CreateObject("System.Text.UTF8Encoding")
    Set enc = CreateObject("System.Security.Cryptography.HMACSHA1")

    TextToHash = asc.GetBytes_4(sTextToHash)
    SharedSecretKey = asc.GetBytes_4(sTextToHash)
    enc.Key = SharedSecretKey

    bytes = enc.ComputeHash_2((TextToHash))
    BASE64SHA1 = EncodeBase64(bytes)
    BASE64SHA1 = Left(BASE64SHA1, cutoff)

    Set asc = Nothing
    Set enc = Nothing

End Function

Private Function EncodeBase64(ByRef arrData() As Byte) As String

    Dim objXML As Object
    Dim objNode As Object

    Set objXML = CreateObject("MSXML2.DOMDocument")
    Set objNode = objXML.createElement("b64")

    objNode.DataType = "bin.base64"
    objNode.nodeTypedValue = arrData
    EncodeBase64 = objNode.Text

    Set objNode = Nothing
    Set objXML = Nothing

End Function

Anyway. Not sure if this is what you were looking for, but thanks for posting the puzzle , and I hope it helps.

JL

 

[MARZIOTULLIO]

Conditional Formatting


=COUNTIF($A$1:$A$4,$A1)>1

applies to =$A$1:$A$4

 

[JumpingCrab]

Conditional Formatting


=COUNTIF($A$1:$A$4,$A1)>1

applies to =$A$1:$A$4

This finds doubles per column, but shows false doubles per row if you drag the formula to the other columns. Am I missing something?

 

[MARZIOTULLIO]

Sorry try

=COUNTIF($A$1:$A$4,A1)>1

applies to =$A$1:$A$4

 

[spacely]

Sorry Jump, I don't get your code. I have rows not columns, so why it's scanning A only?
Not sure where to put the code... I get #NAME ? so far...

Marzio, looks like yours will identify duplicated cells in a column, but not all the combinations that determine if 2 whole rows are identical. Or maybe I need to expand that idea?

 

[Fluff]

How about

Sub ColourDuplicates()

   Dim Valu As String
   Dim Cl As Range
   
   With CreateObject("scripting.dictionary")
      For Each Cl In Range("A1", Range("A" & Rows.Count).End(xlUp))
         Valu = Join(Application.Transpose(Application.Transpose(Cl.Resize(, 8))))
         If Not .exists(Valu) Then
            .Add Valu, Cl.Resize(, 8)
         Else
            Cl.Resize(, 8).Interior.Color = 220
            .Item(Valu).Interior.Color = 220
         End If
      Next Cl
   End With

End Sub

 

[spacely]

Thanks Fluff. With a more general column count, I made it work they way I needed.

Sub ColourDuplicates()
' shift+ctrl+C
Dim Valu As String
Dim Cl As Range

ncol = Selection.Columns.Count
With CreateObject("scripting.dictionary")
For Each Cl In Range("A1", Range("A" & Rows.Count).End(xlUp))
Valu = Join(Application.Transpose(Application.Transpose(Cl.Resize(, ncol + 1))))
If Not .exists(Valu) Then
.Add Valu, Cl.Resize(, ncol + 1)
Else
Cl.Resize(, ncol + 1).Font.Color = vbRed
.Item(Valu).Font.Color = vbRed
End If
Next Cl
End With

End Sub

 

[Fluff]

Glad to help & thanks for the feedback

 

[spacely]

Wait, is there some instance or duplicate rows where it flags all rows to the very bottom of the sheet as duplicate? Somehow every row turned red in one of my tests, but I cannot remember how I was testing it....