This is one way of doing it.
It presumes your original data is in columns A and B and the new data will
be dumped
in columns D and E.
If speed is important then I would use Olaf Schmidt's dhSortedDictionary,
which is in the
dll dhRichClient and that can be downloaded from he
http://www.datenhaus.de/Downloads/dhRichClientDemo.zip

Sub test()

Dim i As Long
Dim x As Long
Dim arr
Dim coll1 As Collection
Dim coll2 As Collection
Dim coll3 As Collection
Dim collIDX As Collection
Dim lIDX As Long
Dim FR As Long
Dim LR As Long

LR = Cells(65536, 1).End(xlUp).Row
FR = Cells(LR, 1).End(xlUp).Row

arr = Range(Cells(FR, 1), Cells(LR, 2))

Set coll1 = New Collection
Set coll2 = New Collection
Set coll3 = New Collection
Set collIDX = New Collection

On Error Resume Next 'skipping duplicate keys
For i = 1 To UBound(arr)

'adding unique column 1 items A etc.
coll1.Add arr(i, 1), arr(i, 1)

'to keep track of the position of the first unique column 1 items
If Err.Number = 0 Then
x = x + 1
collIDX.Add x, arr(i, 1)
End If

'adding unique rows A,H1 etc.
coll2.Add arr(i, 1), arr(i, 1) & arr(i, 2)

'to keep track of unique column 2 items
coll3.Add arr(i, 2), arr(i, 1) & arr(i, 2)

Err.Clear 'needed as we do: If Err.Number = 0
Next i

On Error GoTo 0

ReDim arr(1 To coll1.Count, 1 To 2)

For i = 1 To coll1.Count
arr(i, 1) = coll1(i)
Next i

For i = 1 To coll2.Count
lIDX = collIDX(coll2(i))
If IsEmpty(arr(lIDX, 2)) Then
arr(lIDX, 2) = coll3(i)
Else
arr(lIDX, 2) = arr(lIDX, 2) & "£¬" & coll3(i)
End If
Next i

Range(Cells(4), Cells(UBound(arr), 5)) = arr

End Sub



RBS



"lsy" wrote in message
...
name lx
A H1
A H1
A H2
A H3
B H1
B H2

name lx
A H1£¬H2£¬H3
B H1£¬H2
thx
excel2003