advanced lookup feature

[Southern at Heart]

This may be impossible, but here's what needs to be done.
Sheet1 has a list of parts in column A, & colums B thru F lists components
that make up that part.
Sheet2 column A is a list of components, and I want Column B to list all the
parts (from sheet1!columnA) that use that component.
So in laymens terms, Sheet2B needs to search sheet1B-F and find ALL the
instances of sheet2A. So it may find several parts from sheet 1 that all use
that component, and I need them to be listed in sheet2 next to the component
number
thanks for any help!

 

[carlo]

Hey SaH

I wrote you a small sub:
Enter them in a module in your worksheet, change ws_source and
ws_targets name and run "find_comp"
(the function find_range is a courtesy from OZGrid)

'---------------------------------------------------------------------------------
Sub findComp()

Dim ws_source As Worksheet
Dim ws_target As Worksheet

Set ws_source = Worksheets("sheet1")
Set ws_target = Worksheets("sheet2")

ws_target.Range("B1:IV65536").Delete

Dim coll_ As Collection

For i = 1 To ws_target.Cells(65536, 1).End(xlUp).Row
Set coll_ = Return_Items(ws_target.Cells(i, 1), ws_source)

count_ = 2

For Each itm In coll_
ws_target.Cells(i, count_) = itm
count_ = count_ + 1
Next itm

Next i

End Sub

Function Return_Items(Item As String, WS As Worksheet) As Collection

On Error Resume Next

Dim rng As Range
Dim cell_ As Range
Dim temp As New Collection

Set rng = Find_Range(Item, WS.Range("B1:F" & WS.Cells(65536,
1).End(xlUp).Row))

For Each cell_ In rng
temp.Add WS.Cells(cell_.Row, 1), CStr(WS.Cells(cell_.Row, 1))
Next cell_

Set Return_Items = temp

End Function

Function Find_Range(Find_Item As Variant, _
Search_Range As Range, _
Optional LookIn As Variant, _
Optional LookAt As Variant, _
Optional MatchCase As Boolean) As Range

Dim c As Range
If IsMissing(LookIn) Then LookIn = xlValues 'xlFormulas
If IsMissing(LookAt) Then LookAt = xlWhole 'xlPart
If IsMissing(MatchCase) Then MatchCase = False

With Search_Range
Set c = .Find( _
What:=Find_Item, _
LookIn:=LookIn, _
LookAt:=LookAt, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=MatchCase, _
SearchFormat:=False)
If Not c Is Nothing Then
Set Find_Range = c
firstAddress = c.Address
Do
Set Find_Range = Union(Find_Range, c)
Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address <> firstAddress
End If
End With

End Function
'---------------------------------------------------------------------------------

Pay attention, there might be a wordwrap!!!

hth

Carlo