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