VBA - Msg box if table has duplicate rows

[JamesonMH]

Hi all,

I'm really struggling to find a vba solution here. All I want is a msg box to pop up if my table has duplicate rows.

e.g.

Col 1	Col 2	Col 3
a	x	ee
b	s	rr
d	z	sg
a	x	ee
k	l	aa
a	r	aa

<tbody>
</tbody>

Since row 2 & 5 are dups, I would want the msg box.

Many thanks
James

 

[lrobbo314]

The dictionary resets every time you run the code. I don't understand, with the update from Post#9, how you could be getting that 'Run-time error '457 This key is already associated with element of this collection' error. The 'If Not Dup.exists(temp) Then' should make it impossible to be getting that error on that line.

 

[JamesonMH]

This time I copied/pasted everything out of post #9 , added an End Sub and ran with the same error.

Now I just pasted the #9 code in a completely new workbook and still same error. Sorry for taking up your time on this. I guess I'll go back to the original code which still works perfectly...If you happen to think of anything please let me know on here as I really like the functionality of this 2nd solution.

Thanks again for all your help.
James

 

[lrobbo314]

I figured it out. On that line, I accidentally called the 'tmp' variable 'temp'. The code below should work.

Sub Dupes()
Dim SD As Object: Set SD = CreateObject("Scripting.Dictionary")
Dim Dup As Object: Set Dup = CreateObject("Scripting.Dictionary")
Dim AR() As Variant: AR = Range("A2:C" & Range("A" & Rows.Count).End(xlUp).Row).Value
Dim tmp As String




For i = LBound(AR) To UBound(AR)
    tmp = Join(Application.Transpose(Application.Index(Application.Transpose(AR), 0, i)), ",")
    If Not SD.exists(tmp) Then
        SD.Add tmp, i
    Else
        If Not Dup.exists(tmp) Then Dup.Add tmp, i
        'MsgBox "Duplicate '" & tmp & "' on rows " & SD(tmp) + 1 & " and " & i + 1
    End If
Next i




If Dup.Count = 1 Then
    MsgBox "Duplicate '" & Dup.keys()(0) & "' on row " & Dup.items()(0) + 1
Else
    MsgBox "There are " & Dup.Count & " duplicates in the table"
End If


End Sub

 

[JamesonMH]

Jackpot! I'm all set now.

Thanks again for everything and seeing it through. Cheers!

James

 

[lrobbo314]

Right on! Glad it's working for you. I don't know why I was having issues getting this to work earlier, but I got the code working without using the double 'Transpose' functions. The code below should be marginally more optimized.

Sub Dupes()Dim SD As Object: Set SD = CreateObject("Scripting.Dictionary")
Dim Dup As Object: Set Dup = CreateObject("Scripting.Dictionary")
Dim AR() As Variant: AR = Range("A2:C" & Range("A" & Rows.Count).End(xlUp).Row).Value
Dim tmp As String

For i = LBound(AR) To UBound(AR)
   [COLOR=#0000ff][B] tmp = Join(Application.Index(AR, i, 0), ",")[/B][/COLOR]
    If Not SD.exists(tmp) Then
        SD.Add tmp, i
    Else
        If Not Dup.exists(tmp) Then Dup.Add tmp, i
    End If
Next i


If Dup.Count = 1 Then
    MsgBox "Duplicate '" & Dup.keys()(0) & "' on row " & Dup.items()(0) + 1
Else
    MsgBox "There are " & Dup.Count & " duplicates in the table"
End If

End Sub

 

[JamesonMH]

Now comes the easier way after I get more grey hairs Haha
That's cool I'll use this new way instead, but definitely going to remember the double transpose trick for another day. Dont know how you came up with it, definitely not publicized, but it works well!

 

[lrobbo314]

Changing this. This code will allow you to output the rows the duplicates are on. It's set to output to column G, but you can change that. Thought it might be helpful to know where all the duplicates are.

Sub Dupes()
Dim SD As Object: Set SD = CreateObject("Scripting.Dictionary")
Dim Dup As Object: Set Dup = CreateObject("System.Collections.ArrayList")
Dim AR() As Variant: AR = Range("A2:C" & Range("A" & Rows.Count).End(xlUp).Row).Value
Dim tmp As String


For i = LBound(AR) To UBound(AR)
    tmp = Join(Application.Index(AR, i, 0), ",")
    If Not SD.exists(tmp) Then
        SD.Add tmp, i
    Else
        Dup.Add i + 1
    End If
Next i

Range("G1").Resize(Dup.Count, 1).Value = Application.Transpose(Dup.toarray)


End Sub

 

[JamesonMH]

Yea that would be handy, absolutely. This exceeds expectations! Thank you

 

[lrobbo314]

This exceeds expectations! Thank you

I'll take 'things the ladies never say to me' for $500, Alex.

JK, glad it worked for ya.

 

[JamesonMH]

LOL