Display a message box if you find duplicate rows based on multiple columns

[Siri Jasthi]

Hi All,

Can anyone help me to write a macro to display a message box if you find duplicates based on multiple columns.

I have an excel with 7 columns and rows should be given dynamically.In that 1,3,5 are unique columns so the combination of those records should not be duplicates , if any record is identical with the combination of 1,3,5 then i should get a message box that there are duplicates in these rows.

Example :

column 1 column2 column 3 column 4 column 5 column 6 column 7
Apple Bat Cat Dog Egg Fan Gun
Ant Ball Can Don Eight Fun Gate
Apple Big Cat Den Egg Fin Gin

From the above Row 1 and Row 3 are duplicates because combination of the columns 1,3,5 are identical.So I should get a message box with message as Row 1 and Row 3 are duplicate rows.

 

[Yongle]

This lists all duplicate rows in a message box

Sub FindDuplicates()
'duplicate determined when ALL 3 columns 1,3,5 are identical in another row
    Dim l As Long, r As Long, msg As String
    l = Range("A" & Rows.Count).End(xlUp).Row

    For r = 2 To l
        If Evaluate("COUNTIFS(A:A,A" & r & ",C:C,C" & r & ",E:E,E" & r & ")") > 1 Then msg = msg & vbCr & r
    Next
    MsgBox msg, vbInformation, "DUPLICATE ROWS"
End Sub

 

[Siri Jasthi]

This lists all duplicate rows in a message box

Sub FindDuplicates()
'duplicate determined when ALL 3 columns 1,3,5 are identical in another row
    Dim l As Long, r As Long, msg As String
    l = Range("A" & Rows.Count).End(xlUp).Row

    For r = 2 To l
        If Evaluate("COUNTIFS(A:A,A" & r & ",C:C,C" & r & ",E:E,E" & r & ")") > 1 Then msg = msg & vbCr & r
    Next
    MsgBox msg, vbInformation, "DUPLICATE ROWS"
End Sub

Hi, Thanks a lot it is working good.Can you please explain me each step clearly how it works.
Here r=2 to l means If the rows start with 8 then i need to give r=8 to l??Am I correct.
Please explain me each step clearly.
What is vbCr?
Can I get the duplicate row numbers in the message box in horizontal ??

 

[Yongle]

Please explain me each step clearly

[COLOR=#000080]declare variable types[/COLOR]
Dim l As Long, r As Long, msg As String
[COLOR=#000080]get last row based on last entry in coummn A[/COLOR]
l = Range("A" & Rows.Count).End(xlUp).Row
[COLOR=#000080]consider all values of r from 2 to last row[/COLOR]
For r = 2 To l
[COLOR=#000080]evaluate this Excel formula for every row[/COLOR] =COUNTIF(A:A,A2,C:C,C2,E:E,E2)
[COLOR=#000080]IF value is > 2 then (there is a duplicate) ADD row number to message string
Place each row number on a separate line 
vbcr = [/COLOR]V[COLOR=#000080]irtual [/COLOR]B[COLOR=#000080]asic [/COLOR]C[COLOR=#000080]arriage [/COLOR]R[COLOR=#000080]eturn (=new line)[/COLOR]
If Evaluate("COUNTIFS(A:A,A" & r & ",C:C,C" & r & ",E:E,E" & r & ")") > 1 Then msg = msg & vbCr & r
Next
[COLOR=#000080]Display message string in message box with message box style = vbInformation[/COLOR]
MsgBox msg, vbInformation, "DUPLICATE ROWS"

If the rows start with 8 then i need to give r=8 to l

correct

Can I get the duplicate row numbers in the message box in horizontal ?

replace

msg = msg & vbCr & r

with

msg = msg & "  " & r

 

[Siri Jasthi]

[COLOR=#000080]declare variable types[/COLOR]
Dim l As Long, r As Long, msg As String
[COLOR=#000080]get last row based on last entry in coummn A[/COLOR]
l = Range("A" & Rows.Count).End(xlUp).Row
[COLOR=#000080]consider all values of r from 2 to last row[/COLOR]
For r = 2 To l
[COLOR=#000080]evaluate this Excel formula for every row[/COLOR] =COUNTIF(A:A,A2,C:C,C2,E:E,E2)
[COLOR=#000080]IF value is > 2 then (there is a duplicate) ADD row number to message string
Place each row number on a separate line 
vbcr = [/COLOR]V[COLOR=#000080]irtual [/COLOR]B[COLOR=#000080]asic [/COLOR]C[COLOR=#000080]arriage [/COLOR]R[COLOR=#000080]eturn (=new line)[/COLOR]
If Evaluate("COUNTIFS(A:A,A" & r & ",C:C,C" & r & ",E:E,E" & r & ")") > 1 Then msg = msg & vbCr & r
Next
[COLOR=#000080]Display message string in message box with message box style = vbInformation[/COLOR]
MsgBox msg, vbInformation, "DUPLICATE ROWS"

correct


replace

msg = msg & vbCr & r

with

msg = msg & "  " & r

Hi Thank You so much for your help.

Last one more thing i need please help me.

How to get the message as below in the message box

There are few duplicates found in the 10,11 rows,please correct and execute.

 

[Yongle]

MsgBox "There are few duplicates found in rows " & msg & vbCr & "Please correct and execute"

 

[Siri Jasthi]

MsgBox "There are few duplicates found in rows " & msg & vbCr & "Please correct and execute"

Hi Thank you so much for your help.

One last question can u please help me

I have the macro to delete the duplicate rows
Macro :

lastrow = Worksheets("Data").Cells(Worksheets("Data").Rows.Count, "C").End(xlUp).Row
Worksheets("Data").Range("$C$8:$I$" & lastrow).RemoveDuplicates Columns:=Array(1, 2, 3, 4, 5, 6, 7), Header:=xlYes

From this i need the duplicate row will be deleted so i need a message box that particular row is deleted.

Can you please help me.
Thank you in advance.

 

[Yongle]

In post2 , I gave you code that listed duplicate rows. Here it is:

Sub FindDuplicates()
'duplicate determined when ALL 3 columns 1,3,5 are identical in another row
    Dim l As Long, r As Long, msg As String
    l = Range("A" & Rows.Count).End(xlUp).Row

    For r = 2 To l
        If Evaluate("COUNTIFS(A:A,A" & r & ",C:C,C" & r & ",E:E,E" & r & ")") > 1 Then msg = msg & vbCr & r
    Next
    MsgBox msg, vbInformation, "DUPLICATE ROWS"
End Sub

In post7, you are asking a similar question
- the range is different
- there are 7 columns instead of 3
- the column letters are different
- amend the above code to match your new situation
- your code should be palced immediately above this line

Worksheets("Data").Range("$C$8:$I$" & lastrow).RemoveDuplicates Columns:=Array(1, 2, 3, 4, 5, 6, 7), Header:=xlYes

 

[Siri Jasthi]

In post2 , I gave you code that listed duplicate rows. Here it is:

Sub FindDuplicates()
'duplicate determined when ALL 3 columns 1,3,5 are identical in another row
    Dim l As Long, r As Long, msg As String
    l = Range("A" & Rows.Count).End(xlUp).Row

    For r = 2 To l
        If Evaluate("COUNTIFS(A:A,A" & r & ",C:C,C" & r & ",E:E,E" & r & ")") > 1 Then msg = msg & vbCr & r
    Next
    MsgBox msg, vbInformation, "DUPLICATE ROWS"
End Sub

In post7, you are asking a similar question
- the range is different
- there are 7 columns instead of 3
- the column letters are different
- amend the above code to match your new situation
- your code should be palced immediately above this line

Worksheets("Data").Range("$C$8:$I$" & lastrow).RemoveDuplicates Columns:=Array(1, 2, 3, 4, 5, 6, 7), Header:=xlYes

Sorry to disturb you , actually in my requirement i have two cases.
Case 1: If there are 6 columns , in that 3 columns are unique columns , so if they fill same in the unique columns and different data in other columns then it should display a message like there are duplicates in these rows(As you gave the code that will work).

Case 2 : If all the 6 columns are same in two rows (totally identical) then it should delete one row and to delete that row i have wrote macro like below .

lastrow = Worksheets("Data").Cells(Worksheets("Data").Rows.Count, "C").End(xlUp).Row
Worksheets("Data").Range("$C$8:$I$" & lastrow).RemoveDuplicates Columns:=Array(1, 2, 3, 5, 7), Header:=xlYes

Now i need one extra thing is i need a mesage box which row is deleting .Please help me.

 

[Yongle]

You keep adding more questions "one extra thing", "One last question", "Last one more thing". Why not ask for everything you want at the beginning

Here you go - with detailed explanations

The formula used
So that you understand what the code is doing place this formula in J8 and copy down

=COUNTIFS(C$8:C8,C8,D$8:D8,D8,E$8:E8,E8,F$8:F8,F8,G$8:G8,G8,H$8:H8,H8,I$8:I8,I8)>1

- the formula returns TRUE for rows being deleted based on all 7 columns being the same
- the formula is counting how many times a row is duplicated up to and including the current row
- the first cell of each range is absolute (using $) , the 2nd cell is relative
- the formula only returns TRUE after the first instance of a duplicated row ( >1 does this)

The formula and my code is based on the code you included in post7

The code
The first cell in each range is made absolute by using variable f (which is given value 8 as in your code)
A variable is used to build the string to be evaluated - this is clearer to read

Sub Test()
    Dim l As Long, f As Long, msg As String, fstr As String
    l = Range("C" & Rows.Count).End(xlUp).Row
    f = 8
    For r = f To l
        fstr = "C" & f & ":C" & r & ",C" & r & ",D" & f & ":D" & r & ",D" & r & ",E" & f & ":E" & r & ",E" & r & ",F" & f & ":F" & r & ",F" & r & ",G" & f & ":G" & r & ",G" & r & ",H" & f & ":H" & r & ",H" & r & ",I" & f & ":I" & r & ",I" & r & ""
        If Evaluate("COUNTIFS(" & fstr & ")") > 1 Then msg = msg & vbCr & r
    Next
    MsgBox msg, vbInformation, "DELETED ROWS"
End Sub

Your code changed
In post7 your code was this
Worksheets("Data").Range("$C$8:$I$" & lastrow).RemoveDuplicates Columns:=Array(1, 2, 3, 4, 5, 6, 7), Header:=xlYes

In post9 your code is amended to this
Worksheets("Data").Range("$C$8:$I$" & lastrow).RemoveDuplicates Columns:=Array(1, 2, 3, 5, 7), Header:=xlYes

Amend my code to match your different requirement
I suggest you amend the formula in J2 first (and copy down) to make sure that is giving you the correct results
Then amend the string in the code to match