VBA code to lookup multiple columns using Dictionary

[RahulBakshi]

VBA code to lookup multiple columns using Dictionary. Image of data attached. Thanks

 

[RahulBakshi]

Yes, you are right. We are on the same page.

 

[Tupe77]

1. Fu_TS_DictLookup is a workbook function. It's uses Global dict Object and ColumnMatchARR Variant to avoid repeatedly reading data from the sheet. (Reason for 2.5)
2. It has five parameters.
2.1 "Emp ID" to Lookup(Single cell or horizontal range).
2.2 "SourceHeaders" -range (Select all Source Data -Headers)
2.3 "UniqueKey" -Range(only 1 cell) where to find source "Emp ID" -Header.
2.4 "DestinationHeaders" -Range Defines the desired columns and their order.
2.5 ReReadData is optional boolean parameter to forcing rereading data-range. (Parameter default is False = No ReReadData)
(ReReadData can be changed to default: (Optional ReReadData As Boolean = True))
- Used when the data that is the subject of searches has been changed between searches.
- When destination columns has rearranged
3. There is no error handling or data validations.
4. The VBA code must be placed at the top of the module. (for global statement)
5. Only a few tests done, so need to lot of testing before real use!

My apologies for any quirks, English is not my native language.


Usage:
Single value to Lookup:

=Fu_TS_DictLookup(Lookup value,SourceHeaders,UniqueKeyHeader,DestinationHeaders)
=Fu_TS_DictLookup(I2,A1:G1,D1,J1:N1)

multiple values to Lookup:

=Fu_TS_DictLookup(Lookup values,SourceHeaders,UniqueKeyHeader,DestinationHeaders)
=Fu_TS_DictLookup(I2:I8,A1:G1,D1,J1:N1)

subject of searches has been changed:

=Fu_TS_DictLookup(I2:I8,A1:G1,D1,J1:N1,True)

Option Explicit
Global dict As Object
Global ColumnMatchARR As Variant

Function Fu_TS_DictLookup(EmpIdRNG As Range, SourceHeaders As Range, UniqueKey As Range, DestinationHeaders As Range, Optional ReReadData As Boolean = False) As Variant()
Dim DataRange As Range, IdRNG As Range
Dim SourceHeadersARR As Variant, DestinationHeadersARR As Variant
Dim ws As Worksheet: Set ws = Worksheets(UniqueKey.Parent.Name)
Dim iDHA As Long, iSHA As Long, EmpID As Long

' Range where to find all "Emp ID"s
Set IdRNG = ws.Range(UniqueKey.Offset(1, 0).Address & ":" & Split(UniqueKey.Address, "$")(1) & ws.Cells(Rows.Count, 4).End(xlUp).Row)

'Get DataRange
Set DataRange = ws.Range(SourceHeaders.Cells(1).Offset(1, 0).Address & ":" & SourceHeaders.Cells(IdRNG.Cells.Count + 1, SourceHeaders.Columns.Count).Address)

'Read headers
SourceHeadersARR = WorksheetFunction.Transpose(WorksheetFunction.Transpose(DataRange.Rows(1).Offset(-1, 0).Value))
DestinationHeadersARR = WorksheetFunction.Transpose(WorksheetFunction.Transpose(DestinationHeaders.Value))

If dict Is Nothing Or IsEmpty(ColumnMatchARR) Or ReReadData Then ' Reading Data from Sheet
    Debug.Print "No data on memory or data refresh demanded, reading data"
    
    'Create Columns Matching Array (Select Columns and ReArrange)
    ReDim ColumnMatchARR(1 To UBound(DestinationHeadersARR), 1 To 2)
        For iDHA = 1 To UBound(DestinationHeadersARR)
            ColumnMatchARR(iDHA, 1) = DestinationHeadersARR(iDHA)
                For iSHA = LBound(SourceHeadersARR) To UBound(SourceHeadersARR)
                    If SourceHeadersARR(iSHA) = DestinationHeadersARR(iDHA) Then
                        ColumnMatchARR(iDHA, 2) = iSHA
                        Exit For
                    End If
                Next iSHA
        Next iDHA
    
    ' Creating variables
    Set dict = CreateObject("Scripting.Dictionary")
    Dim c As Range
    
    ' Read all data to dictionary
    For Each c In IdRNG
        dict(CLng(c.Value)) = WorksheetFunction.Transpose(WorksheetFunction.Transpose(DataRange.Rows(c.Row - 1).Value)) ' c.value(add key if missing) = range.values to transform to array
    Next

Else ' Data is allready written to Global dict
    Debug.Print "Data allready in Dictionary"
End If

    'Creating variables
    Dim i As Long: i = 1
    Dim FuRows As Long: FuRows = EmpIdRNG.Cells.Count
    Dim HeadersCount As Long: HeadersCount = UBound(DestinationHeadersARR)
    Dim RetArrD2 As Variant
    
    ' Writing demanded data to Array
    Dim j As Long
    ReDim RetArrD2(1 To FuRows, 1 To HeadersCount)
    For Each c In EmpIdRNG
        j = 1
        EmpID = CLng(c.Value)
            For j = 1 To HeadersCount
                RetArrD2(i, j) = dict(EmpID)(ColumnMatchARR(j, 2)) '(2) '
            Next j
        i = i + 1
    Next
    
    ' The return value of Fu_WriteBack is a 2-dimensional RetArrD2 array
    Fu_TS_DictLookup = RetArrD2

End Function

 

[RahulBakshi]

Thank you so much Tupe77.

 

[Tupe77]

Thanks!
I hope the function works as intended.

 

[RahulBakshi]

Just tried now UDF is not working when used on 100,000 data set through VBA or through formula. Will you pls share your email ID, I can share file.

 

[Tupe77]

I'm trying to figure it out.

I set my email as a personal message, but according to the forum rules, the correct way would be to share the file via Dropbox, for example, if possible.

1. The data range is more than 100,000 rows, but how many rows is information returned?
2. Which version of Windows? (7,10,11)
2.1 Windows environment 32 or 64 bit?
3. Excel 32 or 64 bit?

 

[Tupe77]

The performance of the function begins to decrease rapidly as the number of rows increases.
I'm not sure about the usability of the function for the amount of data you mentioned, but it will be seen by testing.

Many changes in the code, but the use of the function has not changed.

1. Fu_TS_DictLookup is a workbook function. It's uses Global dict Object and ColumnMatchARR Variant to avoid repeatedly reading data from the sheet. (Reason for 2.5)
2. It has five parameters.
2.1 "IdRNG" to Lookup(Single cell or horizontal range).
2.2 "SourceHeaders" -range (Select all Source Data -Headers)
2.3 "UniqueKey" -Range(only 1 cell) where to find source "Emp ID" -Header.
2.4 "DestinationHeaders" -Range Defines the desired columns and their order.
2.5 ReReadData is optional boolean parameter to forcing rereading data-range. (Parameter default is False = No ReReadData)
(ReReadData can be changed to default: (Optional ReReadData As Boolean = True))
- Used when the data that is the subject of searches has been changed between searches.
- When destination columns has rearranged Headlines are always readed.
3. There is no error handling or data validations. A few check points added.
4. The VBA code must be placed at the top of the module. (for global statement)
5. Only a few tests done, so need to lot of testing before real use!

My apologies for any quirks, English is not my native language.


Usage:
Single value to Lookup:

=Fu_TS_DictLookup(Lookup value,SourceHeaders,UniqueKeyHeader,DestinationHeaders)
=Fu_TS_DictLookup(I2,A1:G1,D1,J1:N1)

multiple values to Lookup:

=Fu_TS_DictLookup(Lookup values,SourceHeaders,UniqueKeyHeader,DestinationHeaders)
=Fu_TS_DictLookup(I2:I8,A1:G1,D1,J1:N1)

subject of searches has been changed:

=Fu_TS_DictLookup(I2:I8,A1:G1,D1,J1:N1,True)

Option Explicit
Global dict As Object
Global ColumnMatchARR As Variant
Global OldDataRangeSTR As String

Function Fu_TS_DictLookup(IdRNG As Range, SourceHeaders As Range, UniqueKey As Range, DestinationHeaders As Range, Optional ReReadData As Boolean = False) As Variant()
    Dim DataRange As Range, ws As Worksheet: Set ws = Worksheets(UniqueKey.Parent.Name)
    Dim SourceHeadersARR As Variant, DestinationHeadersARR As Variant
    Dim iDHA As Long, iSHA As Long, i As Long
    Dim coT As Double: coT = Timer()
    Call TurnOffFeatures
    On Error GoTo ErrHand
    
' Checking that only Header -cell from UniqueKey -range is selected
    If UniqueKey.Cells.Count > 1 Then
        Set UniqueKey = UniqueKey.Cells(1)
    End If

' Range where to find all "Emp ID"s
    Dim IdARR As Variant: IdARR = ws.Range(UniqueKey.Offset(1, 0).Address & ":" & Split(UniqueKey.Address, "$")(1) & ws.Cells.End(xlDown).Row).Value2
' Get DataRange
    Set DataRange = ws.Range(SourceHeaders.Cells(1).Offset(1, 0).Address & ":" & SourceHeaders.Cells(UBound(IdARR, 1) + 1, SourceHeaders.Columns.Count).Address)
' Read headers
    SourceHeadersARR = WorksheetFunction.Transpose(WorksheetFunction.Transpose(DataRange.Rows(1).Offset(-1, 0).Value2))
    DestinationHeadersARR = WorksheetFunction.Transpose(WorksheetFunction.Transpose(DestinationHeaders.Value2))
    
'Create columns that match the table (selecting and rearranging columns)
    ReDim ColumnMatchARR(1 To UBound(DestinationHeadersARR), 1 To 2)
        For iDHA = 1 To UBound(DestinationHeadersARR)
            ColumnMatchARR(iDHA, 1) = DestinationHeadersARR(iDHA)
                For iSHA = LBound(SourceHeadersARR) To UBound(SourceHeadersARR)
                    If SourceHeadersARR(iSHA) = DestinationHeadersARR(iDHA) Then
                        ColumnMatchARR(iDHA, 2) = iSHA
                        Exit For
                    End If
                Next iSHA
        Next iDHA
        
' Checking that the headers of the target area can be found in the source area.
    For i = 1 To UBound(DestinationHeadersARR)
        If IsEmpty(ColumnMatchARR(i, 2)) Then
            MsgBox "There is no title in the data area for corresponding the title of the return value: " & ColumnMatchARR(i, 1) & vbCrLf & vbCrLf & " Destination Headers must be found from Source Headers", , "ERROR ON DATA HEADERS!": End
        End If
    Next i
        
' If dict Is Nothing Or IsEmpty(ColumnMatchARR) Or ReReadData Then ' Read Data from Sheet: REMOVED! Headers data is checked every time.
If dict Is Nothing Or ReReadData Or OldDataRangeSTR <> DataRange.Address Then ' Read Data from Sheet
    Debug.Print "No data on memory or data refresh demanded, reading data"
    
    ' Creating Dictionary
        Set dict = CreateObject("Scripting.Dictionary")
        
    ' Reading all data to dictionary
        On Error GoTo ErrHandDublicates
            For i = 1 To UBound(IdARR, 1)
                dict.Add CStr(IdARR(i, 1)), DataRange.Rows(i).Value2
            Next
        On Error GoTo -1
    
Else
    Debug.Print "Data allready in Dictionary"
End If

'Creating variables
    Dim j As Long, FuRows As Long: FuRows = IdRNG.Cells.Count
    Dim HeadersCount As Long: HeadersCount = UBound(DestinationHeadersARR)
    Dim EmpIdARR As Variant, RetArrD2 As Variant: ReDim RetArrD2(1 To FuRows, 1 To HeadersCount)

' Creating LookUp -values ARRAY
    If FuRows = 1 Then
        ReDim EmpIdARR(1 To 1, 1 To 1)      ' Forcing Variant to array
        EmpIdARR(1, 1) = IdRNG.Value2    ' LookUp -array get single value for search
    Else
        EmpIdARR = IdRNG.Value2          ' LookUp -array range of values for search
    End If
    
' Writing LookUp -search return values to Array
Dim MissingID As Variant, MissingROW As Long
    For i = 1 To UBound(EmpIdARR, 1)
        For j = 1 To HeadersCount
            If dict.Exists(CStr(EmpIdARR(i, 1))) Then
                RetArrD2(i, j) = dict(CStr(EmpIdARR(i, 1)))(1, ColumnMatchARR(j, 2))
            Else
                MissingID = CStr(EmpIdARR(i, 1))      ' This Lookup value is not found from the data!
                MissingROW = i + 1                  ' A row with a missing Lookup value
                RetArrD2(i, j) = ""                 ' Turns missing Lookup result to empty string.
            End If
        Next j
        If MissingROW > 0 Then Debug.Print "LookUp ID: " & MissingID & " at row: " & MissingROW & " not found from data!": MissingROW = 0
    Next i

' The return value of Fu_TS_DictLookup is a 2-dimensional RetArrD2 array
    Fu_TS_DictLookup = RetArrD2
    
OldDataRangeSTR = DataRange.Address

Debug.Print "Execution of the function Fu_TS_DictLookup took: " & Timer() - coT & " seconds."
ErrHand:
Call TurnOnFeatures

Exit Function
ErrHandDublicates:
    Debug.Print "Error number: " & Err.Number & " " & Err.Description: MsgBox "Value: " & IdARR(i, 1) & " at row: " & WorksheetFunction.Match(IdARR(i, 1), IdARR, 0) + 1 & " have dublicate on row: " & i + 1 & vbCrLf & vbCrLf & " This function does not accept duplicates in Key values!", , "ERROR ON DATA!": Call TurnOnFeatures: End
End Function

Function TurnOffFeatures()
    Application.Calculation = xlManual
    Application.DisplayAlerts = False
    Application.EnableEvents = False
    Application.ScreenUpdating = False
    Application.DisplayStatusBar = False
End Function

Function TurnOnFeatures() 
    Application.Calculation = xlAutomatic
    Application.DisplayAlerts = True
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    Application.DisplayStatusBar = True
End Function


Sub test_Fu_TS_DictLookup() ' Only for Testing from vba
Dim x As Variant
Dim LookUpValuesRNG As Range, SourceHeadersRNG As Range, UniqueKeyRNG As Range, DestinationHeadersRNG As Range, DestinationRNG As Range
Dim wsData As Worksheet, wsReturnValue As Worksheet

Set wsData = Worksheets("Sheet4")           ' Sheet where Data found
Set wsReturnValue = Worksheets("Sheet5")    ' Sheet where writing LookUp data back

Set LookUpValuesRNG = wsReturnValue.Range("A2:A" & wsReturnValue.Range("A2").Cells.End(xlDown).Row) ' Values to search for
Set SourceHeadersRNG = wsData.Range("A1:G1")                                                        ' Data headers
Set UniqueKeyRNG = wsData.Range("D1")                                                               ' Header for Data Unique Key
Set DestinationHeadersRNG = wsReturnValue.Range("B1:G1")                                            ' The headers of the values to return from dictionary

x = Fu_TS_DictLookup(LookUpValuesRNG, SourceHeadersRNG, UniqueKeyRNG, DestinationHeadersRNG)

Set DestinationRNG = wsReturnValue.Range("B2:G" & LookUpValuesRNG.Cells.Count + 1)
DestinationRNG.Value2 = x ' Writing LookUp data back to Sheet
End Sub

 

[Tupe77]

for fast testing
Put this to: Dictionary and Array to get the Answer - Answer - Backup1.xlsb -> Sheet5 -> N1

=Fu_TS_DictLookup(M2:M100000,Sheet4!A1:G1,Sheet4!D1,Sheet5!N1:S1)

 

[RahulBakshi]

Thanks Tupe, the solution provided by you is very much appreciated. The scope of the question has been met. Once can use both as UDF or from VBA. Once can use this on very large datasets too.