Rows with duplicate values merge and delete duplicate keep unique value in row

[moscott75]

I am trying to get my table to look like table 2. Any help would be appreciated.


[TABLE="width: 406"]
<tbody>[TR]
[TD]Name[/TD]
[TD]Address[/TD]
[TD]Insured Address[/TD]
[TD]Policy[/TD]
[TD]Policy2[/TD]
[/TR]
[TR]
[TD]John Doe[/TD]
[TD]123 ABC ST[/TD]
[TD] 123 ABC ST[/TD]
[TD]8888A[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]John Doe[/TD]
[TD]123 ABC ST[/TD]
[TD] 123 ABC ST[/TD]
[TD]9999B[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]MIKE A[/TD]
[TD]345 CCC ST[/TD]
[TD] 345 CCC ST[/TD]
[TD]5555C[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]MIKE A[/TD]
[TD]345 CCC ST[/TD]
[TD] 345 CCC ST[/TD]
[TD]4444D[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]TOM[/TD]
[TD]657 TTT AVE[/TD]
[TD] 657 TTT AVE[/TD]
[TD]3333P[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]TOM[/TD]
[TD]698 SS AVE[/TD]
[TD] 698 SS AVE[/TD]
[TD]2222Q[/TD]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Name[/TD]
[TD]Address[/TD]
[TD]Insured Address[/TD]
[TD]Policy[/TD]
[TD]Policy2[/TD]
[/TR]
[TR]
[TD]John Doe[/TD]
[TD]123 ABC ST[/TD]
[TD] 123 ABC ST[/TD]
[TD]8888A[/TD]
[TD]9999B[/TD]
[/TR]
[TR]
[TD]MIKE A[/TD]
[TD]345 CCC ST[/TD]
[TD] 345 CCC ST[/TD]
[TD]5555C[/TD]
[TD]4444D[/TD]
[/TR]
[TR]
[TD]TOM[/TD]
[TD]657 TTT AVE[/TD]
[TD] 657 TTT AVE[/TD]
[TD]3333P[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]TOM[/TD]
[TD]698 SS AVE[/TD]
[TD] 698 SS AVE[/TD]
[TD]2222Q[/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]

 

[MickG]

Try this:-

[COLOR="Navy"]Sub[/COLOR] MG25Jul27
[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] txt [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String,[/COLOR] nRng [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Set[/COLOR] Rng = Range("A2", Range("A" & Rows.Count).End(xlUp))
[COLOR="Navy"]With[/COLOR] CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
    txt = Join(Application.Index(Dn.Resize(, 3).Value, 0, 0), ",")
    [COLOR="Navy"]If[/COLOR] Not .Exists(txt) [COLOR="Navy"]Then[/COLOR]
        .Add (txt), Dn
     [COLOR="Navy"]Else[/COLOR]
        [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)
       .Item(txt).Offset(, 4).Value = .Item(txt).Offset(, 4) & IIf(.Item(txt).Offset(, 4).Value _
       = "", Dn.Offset(, 3).Value, "," & Dn.Offset(, 3).Value)
       
       [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