Here's a fully-worked out demo (including test data creation)
Add a class module with this code and name it KeyMap
Option Explicit
Dim col As Collection
Sub AddData(data, keyCol As Long, valueCol As Long)
Dim r As Long, k As String, v
If col Is Nothing Then Set col = New Collection
For r = 1 To UBound(data, 1)
k = CStr(data(r, keyCol))
If Len(k) > 0 Then
v = data(r, valueCol)
On Error Resume Next
col.Add v, k
On Error GoTo 0
End If
Next r
End Sub
Function GetValue(ByVal k)
Dim result
If Len(k) > 0 Then
On Error Resume Next '### ignore error on duplicate key
result = col(CStr(k))
On Error GoTo 0 'stop ignoring errors
End If
GetValue = IIf(IsEmpty(result), CVErr(xlErrNA), result)
End Function
Property Get Count() As Long
Count = col.Count
End Property
Here's how you can use the class as a lookup after adding data from each of your 3 worksheets:
Sub LookupTester()
Dim map As KeyMap, t, i As Long, result, fmt, wb As Workbook
Dim lookups, rng As Range, ws As Worksheet, col As Long
Set wb = ThisWorkbook
Set ws = wb.Worksheets("Lookups")
Set map = New KeyMap
t = Timer
'Note my dummy data has only two columns: keys in A and values in B
map.AddData DataNoHeader(wb.Worksheets("Listing1").Range("A1")), 1, 2
map.AddData DataNoHeader(wb.Worksheets("Listing2").Range("A1")), 1, 2
map.AddData DataNoHeader(wb.Worksheets("Listing3").Range("A1")), 1, 2
Debug.Print "Initialized map in " & Round(Timer - t, 1) & _
" sec (" & map.Count & " items)"
'read the lookup data from the sheet
Set rng = ws.Range("A2:D" & ws.Cells(ws.Rows.Count, "A").End(xlUp).Row)
lookups = rng.Value
t = Timer
'do some lookups
Debug.Print "Performing " & UBound(lookups, 1) & " lookups"
For i = 1 To UBound(lookups, 1)
For col = 1 To 3
result = map.GetValue(lookups(i, col))
If Not IsError(result) Then Exit For
Next col
lookups(i, 4) = result
Next i
rng.Value = lookups
Debug.Print "Lookups done in " & Round(Timer - t, 4) & " sec"
End Sub
'return data as an array, excluding the first row of headers
Function DataNoHeader(cTopLeft As Range)
Dim rng As Range
Set rng = cTopLeft.CurrentRegion 'assumes no empty rows/columns in the data
Set rng = rng.Offset(1, 0).Resize(rng.Rows.Count - 1)
DataNoHeader = rng.Value
End Function
Notes
- It's much quicker to set up a keyed Collection than a Dictionary when you have a large number of keys, and the lookups are also much faster
- Assumes all keys can be string-type, and unique for all data added to the lookup (duplicates just get ignored), and that lookups are case-insensitive.
- Runtime in my testing as about 15 seconds to set up the mapping (3 sheets x 1M rows each), and about 0.5 seconds to lookups for 20k rows
Here's the code I used to create test data and the lookup table:
'################# All code below was for setting up test data"
Sub SetupTestData()
Const NUM_DATA_ROWS As Long = 1000000# 'rows per sheetin the 3 listings
Const NUM_LOOKUP_ROWS As Long = 20000 'rows to perform lookups on
Dim wb As Workbook, ws As Worksheet, i As Long, col As Long, rw As Long, c As Long, v
Set wb = ThisWorkbook
CreateTestDataSheet wb, "Listing1", "ID", NUM_DATA_ROWS
CreateTestDataSheet wb, "Listing2", "TA", NUM_DATA_ROWS
CreateTestDataSheet wb, "Listing3", "ISRC", NUM_DATA_ROWS
Set ws = wb.Worksheets.Add(before:=wb.Worksheets("Listing1"))
ws.Name = "Lookups"
ws.Range("A1").Resize(1, 4).Value = Array("Listing1", "Listing2", "Listing3", "Result")
For i = 1 To NUM_LOOKUP_ROWS
col = Application.RandBetween(1, 3)
rw = Application.RandBetween(1, NUM_DATA_ROWS)
For c = 1 To 3
If c <> col Then
ws.Cells(i + 1, c).Value = "xxxxxxxx" 'no match
Else
ws.Cells(i + 1, c).Value = wb.Worksheets("listing" & col).Cells(rw, 1).Value
End If
Next c
Next i
ws.Columns.AutoFit
End Sub
Sub CreateTestDataSheet(wb As Workbook, sheetName As String, idPrefix As String, _
numRows As Long)
Dim data, ws As Worksheet
Set ws = wb.Worksheets.Add(after:=wb.Worksheets(wb.Worksheets.Count))
ws.Name = sheetName
data = TestData(idPrefix, numRows)
ws.Range("A1").Resize(1, 3).Value = Array("ID", "Value", "Sort") 'add headers
ws.Range("A2").Resize(UBound(data, 1), UBound(data, 2)).Value = data
With ws.Range("C2").Resize(UBound(data, 1))
.Formula = "=RAND()"
.Value = .Value
End With
With ws.Sort 'randomize the listing order
.SortFields.Clear
.SortFields.Add2 Key:=ws.Range("C2"), SortOn:=xlSortOnValues, Order:=xlAscending
.SetRange ws.Range("A1").CurrentRegion
.Header = xlYes
.Apply
End With
ws.Columns(3).Delete 'delete "sort" column
ws.Range("A:B").Columns.AutoFit
End Sub
'Returns an array of size `numRows` x 2 with dummy data (keys and values)
Function TestData(label As String, numRows As Long)
Dim arr(), r As Long, k
ReDim arr(1 To numRows, 1 To 2)
For r = 1 To numRows
k = label & "_" & Format(r, "0000000")
arr(r, 1) = k
arr(r, 2) = k & "_value"
Next r
TestData = arr
End Function
=IFERROR(INDEX('[data.xlsx]Sheet1'!$G:$G,MATCH([ID],'[data.xlsx]Sheet1'!$A:$A,0)),IFERROR(INDEX('[data.xlsx]Sheet2'!$G:$G,MATCH([ta],'[data.xlsx]Sheet2'!$E:$E,0)),INDEX('[data.xlsx]Sheet3'!$G:$G,MATCH([ISRC],'[data.xlsx]Sheet3'!$F:$F,0)))). Then you can simply link your table column to the outside columnMATCHso not really worth involving VBA here. Of course, in the above suggested formula, if you link from outside the table thenMATCH([ID],...is not valid, so just replace with the table name e.g.MATCH(myTableName[ID],.... Same for[ta]andISRC.