The data should have headers to columns A & B for the filter to function
and assumes the code below with no spaces.


Option Explicit
Sub Joins()
Dim rng As Range, cel As Range
Dim i As Long, txt As String
'Filter unique records
Range("A1").CurrentRegion.AdvancedFilter Action:=xlFilterCopy,
CopyToRange:=Range("E1"), Unique:=True
'Get range of numbers
Set rng = Range("E1").CurrentRegion.Columns(1)
'Loop through range
For i = rng.Cells.Count To 1 Step -1
'Find first instance of number
Set cel = rng.Find(Cells(i, 5), After:=Cells(1, 5),
LookIn:=xlValues, Lookat:=xlWhole)
'Get name
txt = Cells(i, 6)

If Not i = cel.Row Then
'Append name to first occurrence of number
cel.Offset(, 1) = cel.Offset(, 1) & "; " & txt
'Delete copied data
Cells(i, 5).Resize(, 2).Delete shift:=xlUp
End If
Next
End Sub


--
mdmackillop
------------------------------------------------------------------------
mdmackillop's Profile: http://www.thecodecage.com/forumz/member.php?userid=113
View this thread: http://www.thecodecage.com/forumz/sh...ad.php?t=67468