Hi,

Am Sat, 2 Nov 2013 07:24:34 +0000 schrieb mdIsmailkm:

1 | Apple | A4
2 | Orange | A6
3 | Mango | no-match
4 | Apple | A1
5 | Grapes | no-match
6 | Orange | A2
7 | Pineapple | no-match

insert a header in column A and then try:

Sub Test()
Dim LRow As Long
Dim LRow2 As Long
Dim c As Range
Dim i As Long
Dim firstaddress As String

Sheets.Add After:=Sheets(Sheets.Count)
ActiveSheet.Name = "Temp"

With Sheets("Sheet1")
.Columns("A:A").AdvancedFilter Action:=xlFilterCopy, _
CopyToRange:=Range("A1"), Unique:=True
LRow = .Cells(.Rows.Count, 1).End(xlUp).Row
LRow2 = Sheets("Temp").Cells(.Rows.Count, 1).End(xlUp).Row
For i = 2 To LRow2
If WorksheetFunction.CountIf(.Range("A1:A" & LRow), _
Sheets("Temp").Cells(i, 1)) = 1 Then
Sheets("Temp").Cells(i, 2) = "no match"
Else
Set c = .Range("A1:A" & LRow).Find(Sheets("Temp") _
.Cells(i, 1), LookIn:=xlValues, lookat:=xlWhole)
If Not c Is Nothing Then
firstaddress = c.Address
Do
Sheets("Temp").Cells(i, 2) = Sheets("Temp") _
.Cells(i, 2) & c.Address(0, 0) & ", "
Set c = .Range("A1:A" & LRow).FindNext(c)
Loop While Not c Is Nothing And c.Address < firstaddress
End If
End If
Next
With .Range("B2:B" & LRow)
.Formula = "=Substitute(Vlookup(A2,Temp!" & Range("A2:B" & LRow2)
_
.Address & ",2,0),Address(Row(),1,4) & "", "",)"
.Value = .Value
End With
End With
Application.DisplayAlerts = False
Sheets("Temp").Delete
Application.DisplayAlerts = True
End Sub


Regards
Claus B.
--
Win XP PRof SP2 / Vista Ultimate SP2
Office 2003 SP2 /2007 Ultimate SP2