How to extract multiple values from same lookup

[nuckfuts]

Hi -

I'm looking to extract multiple Unique ID's based on a few specific Values. The condensed table below shows the source data (Sheet2). Based on Values listed in Sheet1, I'd like to extract all relevant Unique ID's.

I've considered array formulas, although I try to avoid those when possible for processing speed. I've also found ways to filter the table by the values in the cells but all solutions list out each criteria/filter/Value as a separate line of code and may be extremely repetitive considering there could be 20+ values. Is there a good way to do this?

Sheet2:

Sheet1:
Value1
Value2
Value3
...
(could be 20+ values)

 

[Zot]

Code using VBA
This code will look for all the Value listed on Sheet1. Extract data from Sheet2 and create result in a sheet called Result

Sub ExtractValue()

Dim n As Long
Dim cellValue As Range, cellID As Range, rngValue As Range, rngID As Range
Dim wb As Workbook
Dim wsData As Worksheet, wsValue As Worksheet, wsResult As Worksheet

Set wb = ThisWorkbook
Set wsValue = wb.Sheets("Sheet1")
Set wsData = wb.Sheets("Sheet2")

Set rngValue = wsValue.Range("A1", "A" & wsValue.Range("A1").End(xlDown).Row)
Set rngID = wsData.Range("B2", "B" & wsData.Range("B1").End(xlDown).Row)

wb.Sheets.Add(After:=Sheets(Sheets.Count)).Name = "Result"
Set wsResult = wb.Sheets("Result")

wsResult.Range("A1") = "Value"
wsResult.Range("B1") = "Unique ID"
n = 1

For Each cellValue In rngValue
    wsResult.Range("A" & n + 1) = cellValue
    For Each cellID In rngID
        If cellID = cellValue Then
            n = n + 1
            wsResult.Range("B" & n) = cellID.Offset(0, -1)
        End If
    Next
Next

End Sub

 

[Fluff]

How about

+Fluff v2.xlsm
	A	B	C	D	E	F
1	Postcode	County
2	CA11 0SA	Cumbria			Cumbria	CA11 0SA
3	DY14 0JB	Shropshire			West Yorkshire	OL14 6XB
4	EX22 7NB	Devon			Surrey	BD12 8DW
5	OL14 6XB	West Yorkshire				CR3 9BS
6	BD12 8DW	West Yorkshire				HD8 8EB
7	PL18 9HR	Cornwall				HD7 6DB
8	SK6 7HW	Greater Manchester				BD4 6JF
9	TN27 0HW	Kent				CA10 3JE
10	BB1 8JR	Lancashire
11	NE19 2LS	Northumberland
12	BA4 4FG	Somerset
13	CR3 9BS	Surrey
14	DH9 6TQ	County Durham
15	ST1 2HT	Staffordshire
16	RG9 6YJ	Buckinghamshire
17	TN16 3DX	Greater London
18	BB8 0PG	Lancashire
19	DL6 3AQ	North Yorkshire
20	ST8 6JA	Staffordshire
21	B31 5HY	West Midlands
22	HD8 8EB	West Yorkshire
23	PL32 9RH	Cornwall
24	HD7 6DB	West Yorkshire
25	BB12 9QJ	Lancashire
26	YO18 8RE	North Yorkshire
27	ST6 8LB	Staffordshire
28	WS12 2EW	Staffordshire
29	BD4 6JF	West Yorkshire
30	CA10 3JE	Cumbria
31
Main

Cell Formulas
Range	Formula
F2:F9	F2	=UNIQUE(FILTER(A2:A30,COUNTIF(E2:E4,B2:B30)))
Dynamic array formulas.

 

[nuckfuts]

Code using VBA
This code will look for all the Value listed on Sheet1. Extract data from Sheet2 and create result in a sheet called Result

Sub ExtractValue()

Dim n As Long
Dim cellValue As Range, cellID As Range, rngValue As Range, rngID As Range
Dim wb As Workbook
Dim wsData As Worksheet, wsValue As Worksheet, wsResult As Worksheet

Set wb = ThisWorkbook
Set wsValue = wb.Sheets("Sheet1")
Set wsData = wb.Sheets("Sheet2")

Set rngValue = wsValue.Range("A1", "A" & wsValue.Range("A1").End(xlDown).Row)
Set rngID = wsData.Range("B2", "B" & wsData.Range("B1").End(xlDown).Row)

wb.Sheets.Add(After:=Sheets(Sheets.Count)).Name = "Result"
Set wsResult = wb.Sheets("Result")

wsResult.Range("A1") = "Value"
wsResult.Range("B1") = "Unique ID"
n = 1

For Each cellValue In rngValue
    wsResult.Range("A" & n + 1) = cellValue
    For Each cellID In rngID
        If cellID = cellValue Then
            n = n + 1
            wsResult.Range("B" & n) = cellID.Offset(0, -1)
        End If
    Next
Next

End Sub

I gave it a shot but don't think it's running correctly - or perhaps it is and it just takes a really long time to run. My source data has ~8k rows of data but it seems like it's trying to process more than it should. Had to quit Excel both times due to it freezing up for so long.

 

[nuckfuts]

How about

+Fluff v2.xlsm
	A	B	C	D	E	F
1	Postcode	County
2	CA11 0SA	Cumbria			Cumbria	CA11 0SA
3	DY14 0JB	Shropshire			West Yorkshire	OL14 6XB
4	EX22 7NB	Devon			Surrey	BD12 8DW
5	OL14 6XB	West Yorkshire				CR3 9BS
6	BD12 8DW	West Yorkshire				HD8 8EB
7	PL18 9HR	Cornwall				HD7 6DB
8	SK6 7HW	Greater Manchester				BD4 6JF
9	TN27 0HW	Kent				CA10 3JE
10	BB1 8JR	Lancashire
11	NE19 2LS	Northumberland
12	BA4 4FG	Somerset
13	CR3 9BS	Surrey
14	DH9 6TQ	County Durham
15	ST1 2HT	Staffordshire
16	RG9 6YJ	Buckinghamshire
17	TN16 3DX	Greater London
18	BB8 0PG	Lancashire
19	DL6 3AQ	North Yorkshire
20	ST8 6JA	Staffordshire
21	B31 5HY	West Midlands
22	HD8 8EB	West Yorkshire
23	PL32 9RH	Cornwall
24	HD7 6DB	West Yorkshire
25	BB12 9QJ	Lancashire
26	YO18 8RE	North Yorkshire
27	ST6 8LB	Staffordshire
28	WS12 2EW	Staffordshire
29	BD4 6JF	West Yorkshire
30	CA10 3JE	Cumbria
31
Main

Cell Formulas
Range	Formula
F2:F9	F2	=UNIQUE(FILTER(A2:A30,COUNTIF(E2:E4,B2:B30)))
Dynamic array formulas.

I've been hoping to avoid the array formulas as they have slowed down my spreadsheet in the past. When I try to array formula is says "That function isn't valid." highlighting the "filter" in the formula.. My source data is on another sheet if that changes anything.
I'm also running Office 365 MSO 64-bit so now sure what's wrong.

 

[Zot]

I gave it a shot but don't think it's running correctly - or perhaps it is and it just takes a really long time to run. My source data has ~8k rows of data but it seems like it's trying to process more than it should. Had to quit Excel both times due to it freezing up for so long.

Sorry. The code works and I have tried it but for several line mock up data I created. You can speed up execution by adding bold lines. I should have include them. Standard line in most code

Dim n As Long
Dim cellValue As Range, cellID As Range, rngValue As Range, rngID As Range
Dim wb As Workbook
Dim wsData As Worksheet, wsValue As Worksheet, wsResult As Worksheet

[B]Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
[/B]
Set wb = ThisWorkbook
Set wsValue = wb.Sheets("Sheet1")
Set wsData = wb.Sheets("Sheet2")

' [I]Rest of the codes[/I]

            wsResult.Range("B" & n) = cellID.Offset(0, -1)
        End If
    Next
Next

[B]Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic[/B]

End Sub

Note that if the program is interrupted before finishing, the Excel will still be in xlCalculationManual. Any equation will not be calculated automatically until you manually tell so by pressing F9. You can change the Excel mode to auto again File > Option > Formulas there...

 

[Fluff]

I'm also running Office 365 MSO 64-bit so now sure what's wrong.

You obviously don't have the latest update(s)
How about

Sub nuckfuts()
   Dim Ary As Variant
   Dim r As Long
   Dim Dic As Object
   
   Set Dic = CreateObject("scripting.dictionary")
   Ary = Sheets("Sheet1").Range("A1").CurrentRegion.Value2
   For r = 1 To UBound(Ary)
      Dic(Ary(r, 1)) = Empty
   Next r
   Ary = Sheets("Sheet2").Range("A1").CurrentRegion.Value2
   With CreateObject("scripting.dictionary")
      For r = 2 To UBound(Ary)
         If Dic.Exists(Ary(r, 2)) Then .Item(Ary(r, 1)) = Empty
      Next r
      Sheets("Sheet1").Range("B2").Resize(.Count).Value = Application.Transpose(.Keys)
   End With
End Sub

 

[nuckfuts]

You obviously don't have the latest update(s)
How about

Sub nuckfuts()
   Dim Ary As Variant
   Dim r As Long
   Dim Dic As Object
  
   Set Dic = CreateObject("scripting.dictionary")
   Ary = Sheets("Sheet1").Range("A1").CurrentRegion.Value2
   For r = 1 To UBound(Ary)
      Dic(Ary(r, 1)) = Empty
   Next r
   Ary = Sheets("Sheet2").Range("A1").CurrentRegion.Value2
   With CreateObject("scripting.dictionary")
      For r = 2 To UBound(Ary)
         If Dic.Exists(Ary(r, 2)) Then .Item(Ary(r, 1)) = Empty
      Next r
      Sheets("Sheet1").Range("B2").Resize(.Count).Value = Application.Transpose(.Keys)
   End With
End Sub

I get a run-time error '13' for a type mismatch on this line:

Sheets("Sheet1").Range("B2").Resize(.Count).Value = Application.Transpose(.Keys)

Let me know if the following assumptions from the code mirror your setup:
Sheet1: Where values are, starting in A2 (column header in A1)
Sheet2: Where Unique ID's are, starting in A2 (column header in A1)

 

[Fluff]

I've assumed that sheet2 is laid out as per your op & that sheet1 has values in A1 downwards that match values in col B on sheet2

 

[nuckfuts]

I've assumed that sheet2 is laid out as per your op & that sheet1 has values in A1 downwards that match values in col B on sheet2

That makes sense - I was using it like that but I put "Value" as a column header on Sheet1 and that's what was giving me the error. Is there anyway to have the array lookup a different column? Say if the Values are in row "S" rather than "B" as shown in my OP?