dictionary lookup with multiple criteria

A

anaysha

New Member
Joined
Mar 13, 2023
Messages
21
Office Version
  1. 365
Platform
  1. Windows
Hi Team, I working with lakhs of row and apply Index match function with multiple criteria basis appliable date of particular name, which will take much time while processing, can you please help me out to get the VBA dictionary lookup with multiple criteria which give result in minimal time, so that I can utlize my time further for anlysing of data.

Below is the table where I need output:

With Criteria of Column A matched with Data Base file and Column C range >= in data base file column C and Column D<= in data base file column D

1678732150940.png



Data Base:

1678732205746.png
 
Sort by date Sort by votes
Sorry, I missed the notification of your answer..

Using the data you provided, the Dictionary approach performed well; so you should try the following:
VBA Code: 
Sub LFFee()
Dim DataR As Range, QueryR As Range
Dim myDic As Object  'Scripting.Dictionary
Dim wOne, wTwo, oArr(), I As Long, J As Long
Dim myKSplit, myDSplit, myK As String
'
Set DataR = Sheets("Data").Range("A3")          '<<< Starting cell for data in sheet DATA
Set QueryR = Sheets("OutSh").Range("A3")        '<<< Starting point for data in sheet Output
Set OutR = Sheets("OutSh").Range("F3")          '<<< Starting point for the Result
'
Set DataR = Range(DataR, DataR.End(xlDown)).Resize(, 5)
Set QueryR = Range(QueryR, QueryR.End(xlDown)).Resize(, 5)
'
myTim = Timer
Set myDic = CreateObject("Scripting.Dictionary")
myDic.CompareMode = TextCompare
wOne = DataR.Value
wTwo = QueryR.Value
ReDim oArr(1 To UBound(wTwo), 1 To 1)
For I = 1 To UBound(wOne)
    myK = wOne(I, 1) & "--" & wOne(I, 2)
    If myDic.Exists(myK) Then
        myDic.Item(myK) = myDic.Item(myK) & "#,#" & wOne(I, 3) & "##" & wOne(I, 4) & "##" & wOne(I, 5)
    Else
        myDic.Add (myK), wOne(I, 3) & "##" & wOne(I, 4) & "##" & wOne(I, 5)
    End If
Next I
For I = 1 To UBound(wTwo)
'Debug.Print Timer, "a"
    myK = wTwo(I, 1) & "--" & wTwo(I, 2)
    If myDic.Exists(myK) Then
        myKSplit = Split(myDic.Item(myK), "#,#", , vbTextCompare)
        For J = UBound(myKSplit) To 0 Step -1
            myDSplit = Split(myKSplit(J), "##", , vbTextCompare)
            If wTwo(I, 3) >= CDate(myDSplit(0)) And wTwo(I, 4) <= CDate(myDSplit(1)) Then
                oArr(I, 1) = myDSplit(2)
                Exit For
            End If
        Next J
    End If
'Debug.Print Timer, "B"
'DoEvents
Next I
'Output
OutR.Resize(UBound(oArr) + 5, 1).ClearContents
OutR.Resize(UBound(oArr), 1).Value = oArr
Debug.Print Timer - myTim, I
End Sub
In my test workbook I used too often the same key and that made the dictionary quite useless
 
Upvote 0

Excel Facts

Format cells as currency
Select range and press Ctrl+Shift+4 to format cells as currency. (Shift 4 is the $ sign).
Anthony47 said:
Sorry, I missed the notification of your answer..

Using the data you provided, the Dictionary approach performed well; so you should try the following:
VBA Code: 
Sub LFFee()
Dim DataR As Range, QueryR As Range
Dim myDic As Object  'Scripting.Dictionary
Dim wOne, wTwo, oArr(), I As Long, J As Long
Dim myKSplit, myDSplit, myK As String
'
Set DataR = Sheets("Data").Range("A3")          '<<< Starting cell for data in sheet DATA
Set QueryR = Sheets("OutSh").Range("A3")        '<<< Starting point for data in sheet Output
Set OutR = Sheets("OutSh").Range("F3")          '<<< Starting point for the Result
'
Set DataR = Range(DataR, DataR.End(xlDown)).Resize(, 5)
Set QueryR = Range(QueryR, QueryR.End(xlDown)).Resize(, 5)
'
myTim = Timer
Set myDic = CreateObject("Scripting.Dictionary")
myDic.CompareMode = TextCompare
wOne = DataR.Value
wTwo = QueryR.Value
ReDim oArr(1 To UBound(wTwo), 1 To 1)
For I = 1 To UBound(wOne)
    myK = wOne(I, 1) & "--" & wOne(I, 2)
    If myDic.Exists(myK) Then
        myDic.Item(myK) = myDic.Item(myK) & "#,#" & wOne(I, 3) & "##" & wOne(I, 4) & "##" & wOne(I, 5)
    Else
        myDic.Add (myK), wOne(I, 3) & "##" & wOne(I, 4) & "##" & wOne(I, 5)
    End If
Next I
For I = 1 To UBound(wTwo)
'Debug.Print Timer, "a"
    myK = wTwo(I, 1) & "--" & wTwo(I, 2)
    If myDic.Exists(myK) Then
        myKSplit = Split(myDic.Item(myK), "#,#", , vbTextCompare)
        For J = UBound(myKSplit) To 0 Step -1
            myDSplit = Split(myKSplit(J), "##", , vbTextCompare)
            If wTwo(I, 3) >= CDate(myDSplit(0)) And wTwo(I, 4) <= CDate(myDSplit(1)) Then
                oArr(I, 1) = myDSplit(2)
                Exit For
            End If
        Next J
    End If
'Debug.Print Timer, "B"
'DoEvents
Next I
'Output
OutR.Resize(UBound(oArr) + 5, 1).ClearContents
OutR.Resize(UBound(oArr), 1).Value = oArr
Debug.Print Timer - myTim, I
End Sub
In my test workbook I used too often the same key and that made the dictionary quite useless
Click to expand...
Thank you so much Anthony, this script like a magic...really within second output is appearing....I am glad to have this platform where many genius like you are there and providing solution to person who was initially helpless, It is said that if you want something from your heart, then the whole universe tries to make it meet you.

thank you so much once again.
 
Upvote 0
Thank you for the feedback
If that resolve the problem then it'd be better to mark the discussion as Resoved; see the procedure: Mark as Solution
 
Upvote 0
Hi Anthony, I have already marked as resolved as per guide line, once again thanks...

I have another query related to this, please suggest shall i ask in same thread or shall i raise another query.
Anthony47 said:
Thank you for the feedback
If that resolve the problem then it'd be better to mark the discussion as Resoved; see the procedure: Mark as Solution
Click to expand...
 
Upvote 0
If it is the same problem, maybe in a slightly different scenarion, then you may continue this discussion. It it is a new question, maybe with the same database, then it would be better opening a new discussione, and maybe insert a link to dis discussion if what we have done up to now really matters; probably the forum administrators prefer this second option...
 
Upvote 0
Anthony47 said:
If it is the same problem, maybe in a slightly different scenarion, then you may continue this discussion. It it is a new question, maybe with the same database, then it would be better opening a new discussione, and maybe insert a link to dis discussion if what we have done up to now really matters; probably the forum administrators prefer this second option...
Click to expand...
Hi Anthony, Good afternoon, my query is 90% similar to previous one but there is only change, we are getting fee in different different currency and all currency data base tab is separately created in worksheet, but the output when it fetch from above script will look these 3 tabs of created for seperate currency only then match case will reflect in Output sheet.

Regards,
Anaysha

dic. lookup example - example_2.xlsb
ABCDEF
2NameClassFee StartFee EndsCurrencyFee
3Z26261202-Nov-1924-Jun-21USD
4Z26261005-May-1822-Jul-18INR
5Z26261201-Dec-2105-Dec-22EUR
6Z26261202-Dec-2124-Jan-22USD
7Z26261010-Apr-2205-Oct-23USD
8Z26261220-Dec-2307-Mar-24INR
OutSh




dic. lookup example - example_2.xlsb
ABCDEF
2NameClassFee StartFee EndsCurrencyFee
3Z26261202-Nov-1924-Jun-21USD9000
4Z26261005-May-1822-Jul-18USD899
5Z26261201-Dec-2105-Dec-22USD766
Data_USD



dic. lookup example - example_2.xlsb
ABCDEF
2NameClassFee StartFee EndsCurrencyFee
3Z26261202-Dec-2124-Jan-22INR897
4Z26261010-Apr-2205-Oct-23INR766
5Z26261220-Dec-2307-Mar-24INR877
Data_INR



dic. lookup example - example_2.xlsb
ABCDEF
2NameClassFee StartFee EndsCurrencyFee
3Z26261202-Nov-1924-Jun-21EUR76
4Z26261005-May-1822-Jul-18EUR666
5Z26261201-Dec-2105-Dec-22EUR65
6Z26261202-Dec-2124-Jan-22EUR89
7Z26261010-Apr-2205-Oct-23EUR54
8Z26261220-Dec-2307-Mar-24EUR7
Data_EUR
 
Upvote 0
Not sure about the request: do you mean that there are different "Data" sheets for different currencies, so we need to search into the right "Data_XXX" depending on the value in OutSh-column E?
 
Upvote 0
Anthony47 said:
Not sure about the request: do you mean that there are different "Data" sheets for different currencies, so we need to search into the right "Data_XXX" depending on the value in OutSh-column E?
Click to expand...
Yes, Correct once data is search from different tab then data will populate in Output tab, with considering all the parameters as per earlier request against which you have shared the script.
 
Upvote 0
Try this revised macro:
VBA Code: 
Sub LFFeeCURRENCY()
Dim DataR As Range, QueryR As Range
Dim myDic As Object  'Scripting.Dictionary
Dim wOne, wTwo, oArr(), I As Long, J As Long
Dim myKSplit, myDSplit, myK As String
Dim cSh As String, CuRR, CI As Long
'
myTim = Timer
Set myDic = CreateObject("Scripting.Dictionary")
myDic.CompareMode = TextCompare
'
CuRR = Array("USD", "INR", "EUR")                       '<<< Array of Currencies
'
'Create the Dictionary:
For CI = 0 To UBound(CuRR)
    Set DataR = Sheets("Data_" & CuRR(CI)).Range("A3")  '<<< Starting cell for data in sheet DATA
    Set QueryR = Sheets("OutSh").Range("A3")            '<<< Starting point for data in sheet Output
    Set OutR = Sheets("OutSh").Range("F3")              '<<< Starting point for the Result
    '
    Set DataR = Range(DataR, DataR.End(xlDown)).Resize(, 6)
    Set QueryR = Range(QueryR, QueryR.End(xlDown)).Resize(, 6)
    wOne = DataR.Value
'    wTwo = QueryR.Value
'    ReDim oArr(1 To UBound(wTwo), 1 To 1)
    For I = 1 To UBound(wOne)
        myK = wOne(I, 1) & "--" & wOne(I, 2) & "--" & wOne(I, 5)
        If myDic.Exists(myK) Then
            myDic.Item(myK) = myDic.Item(myK) & "#,#" & wOne(I, 3) & "##" & wOne(I, 4) & "##" & wOne(I, 6)
        Else
            myDic.Add (myK), wOne(I, 3) & "##" & wOne(I, 4) & "##" & wOne(I, 6)
        End If
    Next I
Next CI
'
'Search the Dictionary:
wTwo = QueryR.Value
ReDim oArr(1 To UBound(wTwo), 1 To 1)
For I = 1 To UBound(wTwo)
'Debug.Print Timer, "a"
    myK = wTwo(I, 1) & "--" & wTwo(I, 2) & "--" & wTwo(I, 5)
    If myDic.Exists(myK) Then
        myKSplit = Split(myDic.Item(myK), "#,#", , vbTextCompare)
        For J = UBound(myKSplit) To 0 Step -1
            myDSplit = Split(myKSplit(J), "##", , vbTextCompare)
            If wTwo(I, 3) >= CDate(myDSplit(0)) And wTwo(I, 4) <= CDate(myDSplit(1)) Then
                oArr(I, 1) = myDSplit(2)
                Exit For
            End If
        Next J
    End If
'Debug.Print Timer, "B"
'DoEvents
Next I
'Output
OutR.Resize(UBound(oArr) + 5, 1).ClearContents
OutR.Resize(UBound(oArr), 1).Value = oArr
Debug.Print Timer - myTim, I
End Sub
 
Upvote 0
Solution
Anthony47 said:
Try this revised macro:
VBA Code: 
Sub LFFeeCURRENCY()
Dim DataR As Range, QueryR As Range
Dim myDic As Object  'Scripting.Dictionary
Dim wOne, wTwo, oArr(), I As Long, J As Long
Dim myKSplit, myDSplit, myK As String
Dim cSh As String, CuRR, CI As Long
'
myTim = Timer
Set myDic = CreateObject("Scripting.Dictionary")
myDic.CompareMode = TextCompare
'
CuRR = Array("USD", "INR", "EUR")                       '<<< Array of Currencies
'
'Create the Dictionary:
For CI = 0 To UBound(CuRR)
    Set DataR = Sheets("Data_" & CuRR(CI)).Range("A3")  '<<< Starting cell for data in sheet DATA
    Set QueryR = Sheets("OutSh").Range("A3")            '<<< Starting point for data in sheet Output
    Set OutR = Sheets("OutSh").Range("F3")              '<<< Starting point for the Result
    '
    Set DataR = Range(DataR, DataR.End(xlDown)).Resize(, 6)
    Set QueryR = Range(QueryR, QueryR.End(xlDown)).Resize(, 6)
    wOne = DataR.Value
'    wTwo = QueryR.Value
'    ReDim oArr(1 To UBound(wTwo), 1 To 1)
    For I = 1 To UBound(wOne)
        myK = wOne(I, 1) & "--" & wOne(I, 2) & "--" & wOne(I, 5)
        If myDic.Exists(myK) Then
            myDic.Item(myK) = myDic.Item(myK) & "#,#" & wOne(I, 3) & "##" & wOne(I, 4) & "##" & wOne(I, 6)
        Else
            myDic.Add (myK), wOne(I, 3) & "##" & wOne(I, 4) & "##" & wOne(I, 6)
        End If
    Next I
Next CI
'
'Search the Dictionary:
wTwo = QueryR.Value
ReDim oArr(1 To UBound(wTwo), 1 To 1)
For I = 1 To UBound(wTwo)
'Debug.Print Timer, "a"
    myK = wTwo(I, 1) & "--" & wTwo(I, 2) & "--" & wTwo(I, 5)
    If myDic.Exists(myK) Then
        myKSplit = Split(myDic.Item(myK), "#,#", , vbTextCompare)
        For J = UBound(myKSplit) To 0 Step -1
            myDSplit = Split(myKSplit(J), "##", , vbTextCompare)
            If wTwo(I, 3) >= CDate(myDSplit(0)) And wTwo(I, 4) <= CDate(myDSplit(1)) Then
                oArr(I, 1) = myDSplit(2)
                Exit For
            End If
        Next J
    End If
'Debug.Print Timer, "B"
'DoEvents
Next I
'Output
OutR.Resize(UBound(oArr) + 5, 1).ClearContents
OutR.Resize(UBound(oArr), 1).Value = oArr
Debug.Print Timer - myTim, I
End Sub
Click to expand...
Thank you very much Anthony, you are a genius, in first run I have tested its working fine for me.
 
Upvote 0
You must log in or register to reply here.

Similar threads

S
  • Solved
VBA Code for lookup with multiple criteria
Replies
7
Views
425
kvsrinivasamurthy
K
A
  • Question Question
Excel - looking up data with multiple criteria from table/array, date must be same or nearest before the target cell
Replies
8
Views
561
Peter_SSs
Peter_SSs
S
  • Question Question
Multiple Criteria Lookup Return Value
Replies
1
Views
248
Vogateer
V
A
  • Question Question
populate data based on Matching headers for multiple sheets across files
Replies
0
Views
191
Amer Omar
A
S
  • Solved
VBA: Index Match formular with multiple criterias (lookup an value based on multiple criteria)
Replies
9
Views
803
Alex Blakenburg
A

Forum statistics

Threads
1,223,903
Messages
6,175,284
Members
452,630
Latest member
OdubiYouth

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top