Address book linking

[mistrellis]

Need to be pointed in the right direction this is a seasonal question too:

My list contains single people and couples.

Title	SName	Add1	Add2	Add3	Add4	LINK
Mr	Bloggs	No1	Fuff Road	Fuff Town	Fuffington	BLO001
Mrs	Bloggs	No1	Fuff Road	Fuff Town	Fuffington	BLO001
Miss	Housecoat	13	Flower Lane	Tooley	Wooley	HOU001
Dr	Hibbert	56	Town Road	Townshio	Townland	HIB001
Mrs	Hibbert	56	Town Road	Townshio	Townland	HIB001

<tbody>
</tbody>

Is there an easy way to get ?

Title	SName	Add1	Add2	Add3	Add4	LINK
Mr and Mrs	Bloggs	No1	Fuff Road	Fuff Town	Fuffington	BLO001
Miss	Housecoat	13	Flower Lane	Tooley	Wooley	HOU001
Dr and Mrs	Hibbert	56	Town Road	Townshio	Townland	HIB001

<tbody>
</tbody>

 

[CalcSux78]

Not sure if you're comfortable with macros & vba script, but seems like an ultra quick way to fix a massive list.

This will read all of the activesheet into an array, create a Dictionary Object based off of the LINK id, replace the "Title" with the consolidated title, and remove duplicate "LINK" ids.

Sub Consolidate()
Dim rng As Range
Dim rARR As Variant
Dim dTitle As Object    'Dictionary
Dim i&


Set dTitle = CreateObject("Scripting.Dictionary")
Set rng = [A1].CurrentRegion
rARR = rng      'array houses all table data (incl headers)


'Dictionary Key based off of LINK column number (7)


'skip 1st row of array (Title Row)
For i = LBound(rARR, 1) + 1 To UBound(rARR, 1)
    If dTitle.exists(rARR(i, 7)) Then
        dTitle(rARR(i, 7)) = dTitle(rARR(i, 7)) & "|" & Trim(rARR(i, 1))
    Else
        dTitle.Add Key:=rARR(i, 7), Item:=Trim(rARR(i, 1))
    End If
Next i


're-loop through array to replace Title w/ new title
For i = LBound(rARR, 1) + 1 To UBound(rARR, 1)
    rARR(i, 1) = Replace(dTitle(rARR(i, 7)), "|", " & ")
Next i


'send range back to worksheet
rng = rARR


rng.RemoveDuplicates 7, 1
End Sub