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.

Name	Address	Insured Address	Policy	Policy2
John Doe	123 ABC ST	123 ABC ST	8888A
John Doe	123 ABC ST	123 ABC ST	9999B
MIKE A	345 CCC ST	345 CCC ST	5555C
MIKE A	345 CCC ST	345 CCC ST	4444D
TOM	657 TTT AVE	657 TTT AVE	3333P
TOM	698 SS AVE	698 SS AVE	2222Q
Name	Address	Insured Address	Policy	Policy2
John Doe	123 ABC ST	123 ABC ST	8888A	9999B
MIKE A	345 CCC ST	345 CCC ST	5555C	4444D
TOM	657 TTT AVE	657 TTT AVE	3333P
TOM	698 SS AVE	698 SS AVE	2222Q

<tbody>
</tbody>

 

[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