VBA: Merging rows based on duplicate values in two columns

[a098p]

I am trying to merge rows based on duplicate values in two columns. Specifically, look at the two screenshots below. If entries under Last Name (Column B) and Email (Column C) match in any two rows, then they should be merged.

This is what it looks like originally:

First Name	Last Name	Email Address	Cell Phone	Organization Name	Organization Type	Job Title/Designation
ABC	PQR	abcpqr@test.com	xxxxxxxxxx
ABC	PQR	abcpqr@test.com		XYZ	MNC	Student

<tbody>
</tbody>

This is what I would like it to look like:

First Name	Last Name	Email Address	Cell Phone	Organization Name	Organization Type	Job Title/Designation
ABC	PQR	abcpqr@test.com	xxxxxxxxxx	XYZ	MNC	Student

<tbody>
</tbody>

In my workbook, a user is likely to copy paste rows of data and will then run a macro to check for duplicates across Column B and Column C and then merge them if found. There are many more columns than the ones displayed here and the user will be adding new columns so I would like the merge to occur across the entire row. Is there any way to do this?

 

[MickG]

Try this:-
NB:- This code will alter your Data, and delete duplicate rows !!!

[COLOR="Navy"]Sub[/COLOR] MG17Aug22
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range, Dn [COLOR="Navy"]As[/COLOR] Range, n [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Lst [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] txt [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String,[/COLOR] Ac [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] nRng [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Set[/COLOR] Rng = Range("A2", Range("A" & Rows.Count).End(xlUp))
Lst = ActiveSheet.Cells(1).CurrentRegion.Columns.Count
[COLOR="Navy"]With[/COLOR] CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare

[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
    txt = Dn.Value & Dn.Offset(, 1).Value
    [COLOR="Navy"]If[/COLOR] Not .Exists(txt) [COLOR="Navy"]Then[/COLOR]
        .Add txt, Dn
    [COLOR="Navy"]Else[/COLOR]
    [COLOR="Navy"]For[/COLOR] Ac = 2 To Lst - 1
            [COLOR="Navy"]If[/COLOR] .Item(txt).Offset(, Ac) = "" [COLOR="Navy"]Then[/COLOR]
                .Item(txt).Offset(, Ac) = Dn.Offset(, Ac)
            [COLOR="Navy"]End[/COLOR] If
   [COLOR="Navy"]Next[/COLOR] Ac
   [COLOR="Navy"]If[/COLOR] nRng [COLOR="Navy"]Is[/COLOR] Nothing [COLOR="Navy"]Then[/COLOR] [COLOR="Navy"]Set[/COLOR] nRng = Dn Else [COLOR="Navy"]Set[/COLOR] nRng = Union(nRng, Dn)
[COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR]
[COLOR="Navy"]If[/COLOR] Not nRng [COLOR="Navy"]Is[/COLOR] Nothing [COLOR="Navy"]Then[/COLOR] nRng.EntireRow.Delete
[COLOR="Navy"]End[/COLOR] With

[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick