How to do multiple lookups with VBA

[Bassie]

Hey,

I have a list of products that I want to lookup against a big database of products. The difficult part is that one product can have multiple matches in the database and I need to have all matches come up in the results (unlike with vlookup). Also each product has multiple criteria that I want to copy down to the results page.

I made a XL2BB document with hopefully a little bit of a more clear explanation. In reality the database has around 100k rows of data.

Book1
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O
1	Search these		In this table	Colour	Size	Availability	Price			Result:	Colour	Size	Availability	Price
2	1		1	Green	10	Yes	6			1	Green	10	Yes	6
3	2		3	Yellow	12	No	4			1	Green	8	No	4
4	3		1	Green	8	No	4			1	Lightblue	10	No	1
5	4		2	Blue	20	Yes	2			2	Blue	20	Yes	2
6	5		1	Lightblue	10	No	1			3	Yellow	12	No	4
7	6		4	Yellow	12	no	5			4	Yellow	12	no	5
8	7		4	Brown	10	Yes	11			4	Brown	10	Yes	11
9	8		8	Red	22	No	12			6	Purple	16	Yes	2
10			7	Pink	12	No	15			7	Pink	12	No	15
11			6	Purple	16	Yes	2			7	Green	13	Yes	21
12			7	Green	13	Yes	21			8	Red	22	No	12
13			etc
14			etc
15			etc
16
17
18
19
Sheet1

Greetings,

 

[mumps]

Are the search criteria (column A), the search table and result table all in the same sheet? If not, please post XL2BB screenshots of each sheet.

 

[Bassie]

Hey,

Thanks for the tip. They are indeed not in the same sheet, I added a more relevant XL2BB screenshot below:

Search page

Mockup VBA lookup question.xlsx
	A	B	C	D
1	Product	Search these attributes
2	X	1
3	Y	2
4	A	3
5	D	4
6	F	5
7	G	6
8	H	7
9	J	8
10
11
Search this

Database:

Mockup VBA lookup question.xlsx
	A	B	C	D	E
1	In this table	Colour	Size	Availability	Price
2	1	Green	10	Yes	6
3	3	Yellow	12	No	4
4	1	Green	8	No	4
5	2	Blue	20	Yes	2
6	1	Lightblue	10	No	1
7	4	Yellow	12	no	5
8	4	Brown	10	Yes	11
9	8	Red	22	No	12
10	7	Pink	12	No	15
11	6	Purple	16	Yes	2
12	7	Green	13	Yes	21
13	etc
14	etc
15	etc
Database

Results

Mockup VBA lookup question.xlsx
	A	B	C	D	E	F	G
1	Product	Search attribute	Colour	Size	Availability	Price
2	X	1	Green	10	Yes	6
3	X	1	Green	8	No	4
4	X	1	Lightblue	10	No	1
5	Y	2	Blue	20	Yes	2
6	A	3	Yellow	12	No	4
7	D	4	Yellow	12	no	5
8	D	4	Brown	10	Yes	11
9	G	6	Purple	16	Yes	2
10	H	7	Pink	12	No	15
11	H	7	Green	13	Yes	21
12	J	8	Red	22	No	12
13
Results

 

[mumps]

Does the Report sheet contain only the search criteria? Basically I need to know how many sheets we are dealing with and I need to see what each sheet looks like.

 

[ranman256]

this code pulls your search from sheet called FIND (like you have in col.A)
then searches the data in sheet DATA,
then posts results in new sheets.
modify to fit your data

'---------------------
Sub FindMyData()
'---------------------
Dim iRows As Long, iFldNum As Long, iResultOFF As Long
Dim vTxt
Dim sResultCol As String
Const kResultHdr = "Results"
Const kFOUND = "found"
Dim colItems As New Collection
Dim i As Integer
Dim bIsFound As Boolean
  'load the legal search values
Sheets("find").Activate
Range("A1").Select
While ActiveCell.Value <> ""
   colItems.Add ActiveCell.Value
   ActiveCell.Offset(1, 0).Select 'next row
Wend
  'add a result column
Sheets("data").Activate
Range("A1").Select
Selection.End(xlToRight).Select
If InStr(ActiveCell.Value, kResultHdr) = 0 Then
   ActiveCell.Offset(0, 1).Select
   ActiveCell.Value = kResultHdr
End If
iFldNum = ActiveCell.Column
iResultOFF = iFldNum - Range("A1").Column
sResultCol = iFldNum & ":" & iFldNum
sResultCol = getMyColLtr()
  'get #rows
Range("A1").Select
iRows = ActiveSheet.UsedRange.Rows.Count
For i = 1 To colItems.Count
     bIsFound = False
 
      'clear results col.
    Columns(iFldNum).ClearContents
    Range(sResultCol & "1").Value = kResultHdr
   
    'MsgBox iRows
    Range("A2").Select
    While ActiveCell.Row <= iRows
       vTxt = ActiveCell.Offset(0, 0).Value
         
          If Val(vTxt) = Val(colItems(i)) Then
            ActiveCell.Offset(0, iResultOFF).Value = kFOUND
            bIsFound = True
          End If
       
       ActiveCell.Offset(1, 0).Select 'next row
    Wend
        If bIsFound Then
             'filter results
            ActiveSheet.Range("A1").AutoFilter Field:=iFldNum, Criteria1:=kFOUND
       
              'copy the results
                Range("A1").Select
                ActiveSheet.UsedRange.Select
                   
                Selection.Copy
                Sheets.Add After:=ActiveSheet
                ActiveSheet.Paste
                Application.CutCopyMode = False
                ActiveSheet.Name = "val " & colItems(i)
                Sheets("DATA").Select
                 Selection.AutoFilter
                Range("A1").Select
        End If
Next  'item
Set colItems = Nothing

End Sub
'---------------------
Public Function getMyColLtr()
'---------------------
Dim vRet
Dim i As Integer
vRet = Mid(ActiveCell.Address, 2)
i = InStr(vRet, "$")
If i > 0 Then vRet = Left(vRet, i - 1)
getMyColLtr = vRet
End Function