Hello,

I have a script who Seiya give me ones.
I use it now for a bit another purpose, so i had to adjust some things.
In sheet1 i have some names in column B, these names are also
represented in column A of sheet2. In sheet2 at Column B are some
additional infromation (names sometimes more then 1 and seperated with
a ';'). The script search for a match and copy the information to
sheet1 in column C. But when a name is more then ones represented in
Column B of sheet1 he only copy's the additional info with the first
match and skips the other matches.
Can someone tell me what i have to change in the script so he will copy
the information (column B sheet2) with every single match and not only
the first one??

Sub test()
Dim r As Range, txt, ws1 As Worksheet, ws2 As Worksheet
Dim LookUpCell As Range, x
Set ws1 = Worksheets("Sheet1"): Set ws2 = Worksheets("Sheet2")
With ws2
For Each r In .Range("a1", .Range("b65536").End(xlUp))
If Not IsEmpty(r) Then
If InStr(r, ";") = 0 Then
Set LookUpCell = ws1.Range("b:b").Find(what:=r.Value,
lookat:=xlWhole)
If Not LookUpCell Is Nothing Then
LookUpCell.Offset(, 1) = r.Offset(, 1).Value
End If


Else
txt = Split(Replace(r, " ", ""), ";")
For Each x In txt
Set LookUpCell = ws1.Range("b:b").Find(what:=x,
lookat:=xlWhole)
If Not LookUpCell Is Nothing Then
LookUpCell.Offset(, 1) = r.Offset(,
1).Value
End If


Next
End If
End If
Next
Set ws1 = Nothing: Set ws2 = Nothing: Erase txt
End With


End Sub

Chris