Sub bbb()
Dim rngA As Range, rngB As Range
Dim rng As Range, cell As Range
Dim res As Variant
With Worksheets("Sheet1")
Set rngA = .Range(.Cells(2, 1), .Cells(2, 1).End(xlDown))
Set rngB = .Range(.Cells(2, 2), .Cells(2, 2).End(xlDown))
End With
For Each cell In rngA
res = Application.Match("*" & cell.Value & "*", rngB, 0)
If Not IsError(res) Then
Set rng = rngB(res)
rng.Offset(0, 1).Value = cell
End If
Next

End Sub

worked for me. It assumes the lists start in A2 and B2. If in A1 and B1,
change

With Worksheets("Sheet1")
Set rngA = .Range(.Cells(1, 1), .Cells(1, 1).End(xlDown))
Set rngB = .Range(.Cells(1, 2), .Cells(1, 2).End(xlDown))
End With

--
Regards,
Tom Ogilvy

"Jim Jackson" wrote in message
...
In a spreadsheet I have one column with single item names and a second
column
with strings of data. I am trying to set up a routine that will search
the
column with strings for the names found in the first one. The result
needed
is to place the name in a third column adjacent to the one with the string
that contains the name. I have come up with this:

If InStr(Range("B2"), ActiveCell) Then Range("C2") = ActiveCell
If InStr(Range("B3"), ActiveCell) Then Range("C2") = ActiveCell
etc.

This works if I use "Offset" and type a separate line of code for each row
of data but this is rather inconvenient since there are over 1000 rows.

Is there a better way to accomplish this?

Thanks for any help anyone may offer.