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:

[TABLE="class: grid, width: 500, align: left"]
<tbody>[TR]
[TD]First Name[/TD]
[TD]Last Name[/TD]
[TD]Email Address[/TD]
[TD]Cell Phone[/TD]
[TD]Organization Name[/TD]
[TD]Organization Type[/TD]
[TD]Job Title/Designation[/TD]
[/TR]
[TR]
[TD]ABC[/TD]
[TD]PQR[/TD]
[TD]abcpqr@test.com[/TD]
[TD]xxxxxxxxxx[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]ABC[/TD]
[TD]PQR[/TD]
[TD]abcpqr@test.com[/TD]
[TD][/TD]
[TD]XYZ[/TD]
[TD]MNC[/TD]
[TD]Student[/TD]
[/TR]
</tbody>[/TABLE]







This is what I would like it to look like:

[TABLE="class: grid, width: 500, align: left"]
<tbody>[TR]
[TD]First Name[/TD]
[TD]Last Name[/TD]
[TD]Email Address[/TD]
[TD]Cell Phone[/TD]
[TD]Organization Name[/TD]
[TD]Organization Type[/TD]
[TD]Job Title/Designation[/TD]
[/TR]
[TR]
[TD]ABC[/TD]
[TD]PQR[/TD]
[TD]abcpqr@test.com[/TD]
[TD]xxxxxxxxxx[/TD]
[TD]XYZ[/TD]
[TD]MNC[/TD]
[TD]Student[/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]







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