(VBA Function ?) Lookup value and copy it into antoher worksheet

[beety007]

Hi all,

Who can help me with this issue. I have 2 worksheets with specific data
in it (Each Sheet contains about +/- 2000 records) and I would like to
create a very special lookup function. (With copying cells if possible)
To illustrate the problem please take a look at this example:

For Example:

Sheet1:

NAME REFNUMBER COLOR
John 1
Michael 1
Kenneth 2
Keith 1

Sheet 2:

REFNUMBER COLOR
1 Green
1 Green-Blue
1 Green-Yellow
2 Black
2 Black-Yellow
2 Black-Purple
2 Black-Grey
3 Pink

I want to create a lookup function wich will look-up the reference
number in Sheet2 and paste all the corresponding colors value in sheet
1.

So Sheet1 should become:

NAME REFNUMBER COLOR
John 1 Green
Green-Blue
Green-Yellow
Michael 1 Green
Green-Blue
Green-Yellow
Kenneth 2 Black
Black-Yellow
Black-Purple
Black-Grey
Keith 1 Green
Green-Blue
Green-Yellow

Is it possible to crate such a function (with or without VBA Code)

Thanks in advance!

Kind Regards,

 

[Tom Ogilvy]

Sub ABC()
Dim rng As Range
Dim i As Long, refNum As Long
Dim j As Long, cell As Range
With Worksheets("Sheet2")
Set rng = .Range(.Cells(2, 1), .Cells(2, 1).End(xlDown))
End With
i = 2
With Worksheets("Sheet1")
Do
refNum = .Cells(i, 2)
cnt = Application.CountIf(rng, refNum)
If cnt <> 0 Then
If cnt > 1 Then _
.Cells(i + 1, 2).Resize(cnt - 1, 1).EntireRow.Insert
j = i
For Each cell In rng
If cell.Value = refNum Then
.Cells(j, 3).Value = cell.Offset(0, 1).Value
j = j + 1
End If
Next
Else
cnt = 1
End If
i = i + cnt
Loop While Not IsEmpty(.Cells(i, 2))
End With

End Sub