vlookup dictionary approximate match

roykana · Jan 28, 2022

Dear all Master,
below I want the desired result in column E which I marked in yellow and also I use a formula so it's easy to understand what I mean and I want to add a little in the code below without changing the structure of the code below and I also made a vba code for in column E in sheet "selectfile" with marking red but it doesn't work because I'm also wrong in the code

VBA Code:

Sub vloookupdictionary()
Dim Rng As Range, Ds As Range, n As Long, Dic As Object, Source As Variant
Dim Ary As Variant
Dim startTime As Double
Dim endTime As Double
Dim t
t = Timer
endTime = Timer
'Dim startTime As Double
'Dim endTime As Double
Application.ScreenUpdating = False
[COLOR=rgb(209, 72, 65)]With Sheets("DB")
    Source = .Range("C1").CurrentRegion.Resize(, 4)
End With
Set Dic = CreateObject("scripting.dictionary")
Dic.CompareMode = vbBinaryCompare
For n = 2 To UBound(Source, 1)
    Dic(Source(n, 1)) = n
Next

[COLOR=rgb(209, 72, 65)]'result in column E Sheet "selectfile"
With Sheets("SELECTFILE")
    Ary = .Range("C2", .Range("C" & Rows.Count).End(xlUp)).Value2
    ReDim Nary(1 To UBound(Ary), 1 To 3)
    For n = 1 To UBound(Ary)
        If Dic.Exists(Ary(n, 1)) Then
            Nary(n, 1) = Source(Dic(Ary(n, 1)), 4)
        End If
    Next n
    .Range("E2").Resize(UBound(Nary), 1).Value = Nary
End With
With Sheets("DB")
    Source = .Range("i1").CurrentRegion.Resize(, 4)
End With[/COLOR]
Set Dic = CreateObject("scripting.dictionary")
Dic.CompareMode = vbTextCompare
For n = 2 To UBound(Source, 1)
    Dic(Source(n, 1)) = n
Next[/COLOR]
With Sheets("SELECTFILE")
    Ary = .Range("A2", .Range("A" & Rows.Count).End(xlUp)).Value2
    ReDim Nary(1 To UBound(Ary), 1 To 3)
    For n = 1 To UBound(Ary)
        If Dic.Exists(Ary(n, 1)) Then
            Nary(n, 1) = Source(Dic(Ary(n, 1)), 3)
            Nary(n, 2) = Source(Dic(Ary(n, 1)), 2)
        End If
    Next n
    .Range("F2").Resize(UBound(Nary), 2).Value = Nary
End With


Application.ScreenUpdating = True

'Debug.Print "Demo-03????:" & amp; amp; endTime - startTime
Debug.Print "It's done in: " & Timer - t & " seconds"
Debug.Print "Time to complete = " & Timer - startTime & " seconds."
End Sub

desired result

Book3

A

B

C

D

E

F

G

1

ID

DATE & TIME

DATE

YEAR

PERIOD

CATEGORY

LOCATION

2

21/07/2017

20/07/2017

01 Juli-2017

Jul-2017

5014

OTHERS01

NON STAFF

SHOP01

3

27/07/2018

20/07/2018

01 Juli-2018

Jul-2018

5004

OTHERS02

MANAGER

SHOP02

4

27/07/2019

20/07/2019

01 Juli-2019

Jul-2019

5016

OTHERS03

NON STAFF

SHOP03

5

27/07/2020

20/07/2020

01 Juli-2020

Jul-2020

5020

OTHERS04

NON STAFF

SHOP04

6

27/07/2021

20/07/2021

01 Juli-2021

Jul-2021

5008

OTHERS04

NON STAFF

SHOP05

DB

Thanks
roykana

shknbk2 · Jan 28, 2022

I have 2 solutions that I think work.

This first one is a long version like your code with a fix if the SELECTFILE date is not found in Dic. For this, there is an extra For loop (For i = 0 To Dic.Count - 1) to identify the dictionary value that is less than the SELECTFILE date. This probably would only be successful with the dates sorted chronologically like you have them.

VBA Code:

Sub vloookupdictionary()
    Dim Rng As Range, Ds As Range, n As Long, Dic As Object, Source As Variant
    Dim i As Long
    Dim Ary As Variant
    Dim startTime As Double
    Dim endTime As Double
    Dim t
    t = Timer
    endTime = Timer
    'Dim startTime As Double
    'Dim endTime As Double
    
    Application.ScreenUpdating = False
    With Sheets("DB")
        Source = .Range("C1").CurrentRegion.Resize(, 4)
    End With
    Set Dic = CreateObject("scripting.dictionary")
    Dic.CompareMode = vbBinaryCompare
    For n = 2 To UBound(Source, 1)
        Dic(Source(n, 1)) = n
    Next
    
    'result in column E Sheet "selectfile"
    With Sheets("SELECTFILE")
        Ary = .Range("C2", .Range("C" & Rows.Count).End(xlUp)).Value2
        ReDim Nary(1 To UBound(Ary), 1 To 3)
        For n = 1 To UBound(Ary)
            If Dic.Exists(Ary(n, 1)) Then
                Nary(n, 1) = Source(Dic(Ary(n, 1)), 4)
            Else
                For i = 0 To Dic.Count - 1
                    If Ary(n, 1) > Dic.keys()(i) Then
                        Nary(n, 1) = Source(i + 2, 4)
                    End If
                Next i
            End If
        Next n
    End With
    With Sheets("DB")
        Source = .Range("i1").CurrentRegion.Resize(, 4)
    End With
    Set Dic = CreateObject("scripting.dictionary")
    Dic.CompareMode = vbTextCompare
    For n = 2 To UBound(Source, 1)
        Dic(Source(n, 1)) = n
    Next
    With Sheets("SELECTFILE")
        Ary = .Range("A2", .Range("A" & Rows.Count).End(xlUp)).Value2
        For n = 1 To UBound(Ary)
            If Dic.Exists(Ary(n, 1)) Then
                Nary(n, 2) = Source(Dic(Ary(n, 1)), 3)
                Nary(n, 3) = Source(Dic(Ary(n, 1)), 2)
            End If
        Next n
        .Range("E2").Resize(UBound(Nary), 3).Value = Nary
    End With
    
    
    Application.ScreenUpdating = True
    
    'Debug.Print "Demo-03????:" & amp; amp; endTime - startTime
    Debug.Print "It's done in: " & Timer - t & " seconds"
    Debug.Print "Time to complete = " & Timer - startTime & " seconds."
End Sub

This next code is much of the same code, just grouped together. However, there are 2 of the Variant and dictionary objects (Ary1, Ary2, Source1, Source2, etc). It makes the code shorter but works in the same way. Either one should work.

VBA Code:

Sub vloookupdictionary2()
    Dim Rng As Range, Ds As Range, n As Long
    Dim Dic1 As Object, Dic2 As Object
    Dim Source1 As Variant, Source2 As Variant
    Dim i As Long
    Dim Ary1 As Variant, Ary2 As Variant
    Dim startTime As Double
    Dim endTime As Double
    Dim t
    t = Timer
    endTime = Timer
    'Dim startTime As Double
    'Dim endTime As Double
    
    Application.ScreenUpdating = False
    With Sheets("DB")
        Source1 = .Range("C1").CurrentRegion.Resize(, 4)
        Source2 = .Range("I1").CurrentRegion.Resize(, 4)
    End With
    Set Dic1 = CreateObject("scripting.dictionary")
    Set Dic2 = CreateObject("scripting.dictionary")
    Dic1.CompareMode = vbBinaryCompare
    Dic2.CompareMode = vbBinaryCompare
    For n = 2 To UBound(Source1, 1)
        Dic1(Source1(n, 1)) = n
        Dic2(Source2(n, 1)) = n
    Next
    
    'result in column E Sheet "selectfile"
    With Sheets("SELECTFILE")
        Ary1 = .Range("C2", .Range("C" & Rows.Count).End(xlUp)).Value2
        Ary2 = .Range("A2", .Range("A" & Rows.Count).End(xlUp)).Value2
        ReDim Nary(1 To UBound(Ary1), 1 To 3)
        For n = 1 To UBound(Ary1)
            If Dic1.Exists(Ary1(n, 1)) Then
                Nary(n, 1) = Source1(Dic1(Ary1(n, 1)), 4)
            Else
                For i = 0 To Dic1.Count - 1
                    If Ary1(n, 1) > Dic1.keys()(i) Then
                        Nary(n, 1) = Source1(i + 2, 4)
                    End If
                Next i
            End If
            If Dic2.Exists(Ary2(n, 1)) Then
                Nary(n, 2) = Source2(Dic2(Ary2(n, 1)), 3)
                Nary(n, 3) = Source2(Dic2(Ary2(n, 1)), 2)
            End If
        Next n
        .Range("E2").Resize(UBound(Nary), 3).Value = Nary
    End With
    Application.ScreenUpdating = True
    
    'Debug.Print "Demo-03????:" & amp; amp; endTime - startTime
    Debug.Print "It's done in: " & Timer - t & " seconds"
    Debug.Print "Time to complete = " & Timer - startTime & " seconds."
End Sub

roykana · Jan 28, 2022

shknbk2 said:

I have 2 solutions that I think work.

This first one is a long version like your code with a fix if the SELECTFILE date is not found in Dic. For this, there is an extra For loop (For i = 0 To Dic.Count - 1) to identify the dictionary value that is less than the SELECTFILE date. This probably would only be successful with the dates sorted chronologically like you have them.

VBA Code:

Sub vloookupdictionary()
    Dim Rng As Range, Ds As Range, n As Long, Dic As Object, Source As Variant
    Dim i As Long
    Dim Ary As Variant
    Dim startTime As Double
    Dim endTime As Double
    Dim t
    t = Timer
    endTime = Timer
    'Dim startTime As Double
    'Dim endTime As Double
  
    Application.ScreenUpdating = False
    With Sheets("DB")
        Source = .Range("C1").CurrentRegion.Resize(, 4)
    End With
    Set Dic = CreateObject("scripting.dictionary")
    Dic.CompareMode = vbBinaryCompare
    For n = 2 To UBound(Source, 1)
        Dic(Source(n, 1)) = n
    Next
  
    'result in column E Sheet "selectfile"
    With Sheets("SELECTFILE")
        Ary = .Range("C2", .Range("C" & Rows.Count).End(xlUp)).Value2
        ReDim Nary(1 To UBound(Ary), 1 To 3)
        For n = 1 To UBound(Ary)
            If Dic.Exists(Ary(n, 1)) Then
                Nary(n, 1) = Source(Dic(Ary(n, 1)), 4)
            Else
                For i = 0 To Dic.Count - 1
                    If Ary(n, 1) > Dic.keys()(i) Then
                        Nary(n, 1) = Source(i + 2, 4)
                    End If
                Next i
            End If
        Next n
    End With
    With Sheets("DB")
        Source = .Range("i1").CurrentRegion.Resize(, 4)
    End With
    Set Dic = CreateObject("scripting.dictionary")
    Dic.CompareMode = vbTextCompare
    For n = 2 To UBound(Source, 1)
        Dic(Source(n, 1)) = n
    Next
    With Sheets("SELECTFILE")
        Ary = .Range("A2", .Range("A" & Rows.Count).End(xlUp)).Value2
        For n = 1 To UBound(Ary)
            If Dic.Exists(Ary(n, 1)) Then
                Nary(n, 2) = Source(Dic(Ary(n, 1)), 3)
                Nary(n, 3) = Source(Dic(Ary(n, 1)), 2)
            End If
        Next n
        .Range("E2").Resize(UBound(Nary), 3).Value = Nary
    End With
  
  
    Application.ScreenUpdating = True
  
    'Debug.Print "Demo-03????:" & amp; amp; endTime - startTime
    Debug.Print "It's done in: " & Timer - t & " seconds"
    Debug.Print "Time to complete = " & Timer - startTime & " seconds."
End Sub

This next code is much of the same code, just grouped together. However, there are 2 of the Variant and dictionary objects (Ary1, Ary2, Source1, Source2, etc). It makes the code shorter but works in the same way. Either one should work.

VBA Code:

[/QUOTE]

@shknbk2
thanks to the reply from you, for the first solution there is no result for in column E in sheet "SELECTFILE"

shknbk2 said:

I have 2 solutions that I think work.

This first one is a long version like your code with a fix if the SELECTFILE date is not found in Dic. For this, there is an extra For loop (For i = 0 To Dic.Count - 1) to identify the dictionary value that is less than the SELECTFILE date. This probably would only be successful with the dates sorted chronologically like you have them.

VBA Code:

Sub vloookupdictionary()
    Dim Rng As Range, Ds As Range, n As Long, Dic As Object, Source As Variant
    Dim i As Long
    Dim Ary As Variant
    Dim startTime As Double
    Dim endTime As Double
    Dim t
    t = Timer
    endTime = Timer
    'Dim startTime As Double
    'Dim endTime As Double
   
    Application.ScreenUpdating = False
    With Sheets("DB")
        Source = .Range("C1").CurrentRegion.Resize(, 4)
    End With
    Set Dic = CreateObject("scripting.dictionary")
    Dic.CompareMode = vbBinaryCompare
    For n = 2 To UBound(Source, 1)
        Dic(Source(n, 1)) = n
    Next
   
    'result in column E Sheet "selectfile"
    With Sheets("SELECTFILE")
        Ary = .Range("C2", .Range("C" & Rows.Count).End(xlUp)).Value2
        ReDim Nary(1 To UBound(Ary), 1 To 3)
        For n = 1 To UBound(Ary)
            If Dic.Exists(Ary(n, 1)) Then
                Nary(n, 1) = Source(Dic(Ary(n, 1)), 4)
            Else
                For i = 0 To Dic.Count - 1
                    If Ary(n, 1) > Dic.keys()(i) Then
                        Nary(n, 1) = Source(i + 2, 4)
                    End If
                Next i
            End If
        Next n
    End With
    With Sheets("DB")
        Source = .Range("i1").CurrentRegion.Resize(, 4)
    End With
    Set Dic = CreateObject("scripting.dictionary")
    Dic.CompareMode = vbTextCompare
    For n = 2 To UBound(Source, 1)
        Dic(Source(n, 1)) = n
    Next
    With Sheets("SELECTFILE")
        Ary = .Range("A2", .Range("A" & Rows.Count).End(xlUp)).Value2
        For n = 1 To UBound(Ary)
            If Dic.Exists(Ary(n, 1)) Then
                Nary(n, 2) = Source(Dic(Ary(n, 1)), 3)
                Nary(n, 3) = Source(Dic(Ary(n, 1)), 2)
            End If
        Next n
        .Range("E2").Resize(UBound(Nary), 3).Value = Nary
    End With
   
   
    Application.ScreenUpdating = True
   
    'Debug.Print "Demo-03????:" & amp; amp; endTime - startTime
    Debug.Print "It's done in: " & Timer - t & " seconds"
    Debug.Print "Time to complete = " & Timer - startTime & " seconds."
End Sub

This next code is much of the same code, just grouped together. However, there are 2 of the Variant and dictionary objects (Ary1, Ary2, Source1, Source2, etc). It makes the code shorter but works in the same way. Either one should work.

VBA Code:

[/QUOTE]

[QUOTE="shknbk2, post: 5825031, member: 364025"]

Sub vloookupdictionary2()
    Dim Rng As Range, Ds As Range, n As Long
    Dim Dic1 As Object, Dic2 As Object
    Dim Source1 As Variant, Source2 As Variant
    Dim i As Long
    Dim Ary1 As Variant, Ary2 As Variant
    Dim startTime As Double
    Dim endTime As Double
    Dim t
    t = Timer
    endTime = Timer
    'Dim startTime As Double
    'Dim endTime As Double
   
    Application.ScreenUpdating = False
    With Sheets("DB")
        Source1 = .Range("C1").CurrentRegion.Resize(, 4)
        Source2 = .Range("I1").CurrentRegion.Resize(, 4)
    End With
    Set Dic1 = CreateObject("scripting.dictionary")
    Set Dic2 = CreateObject("scripting.dictionary")
    Dic1.CompareMode = vbBinaryCompare
    Dic2.CompareMode = vbBinaryCompare
    For n = 2 To UBound(Source1, 1)
        Dic1(Source1(n, 1)) = n
        Dic2(Source2(n, 1)) = n
    Next
   
    'result in column E Sheet "selectfile"
    With Sheets("SELECTFILE")
        Ary1 = .Range("C2", .Range("C" & Rows.Count).End(xlUp)).Value2
        Ary2 = .Range("A2", .Range("A" & Rows.Count).End(xlUp)).Value2
        ReDim Nary(1 To UBound(Ary1), 1 To 3)
        For n = 1 To UBound(Ary1)
            If Dic1.Exists(Ary1(n, 1)) Then
                Nary(n, 1) = Source1(Dic1(Ary1(n, 1)), 4)
            Else
                For i = 0 To Dic1.Count - 1
                    If Ary1(n, 1) > Dic1.keys()(i) Then
                        Nary(n, 1) = Source1(i + 2, 4)
                    End If
                Next i
            End If
            If Dic2.Exists(Ary2(n, 1)) Then
                Nary(n, 2) = Source2(Dic2(Ary2(n, 1)), 3)
                Nary(n, 3) = Source2(Dic2(Ary2(n, 1)), 2)
            End If
        Next n
        .Range("E2").Resize(UBound(Nary), 3).Value = Nary
    End With
    Application.ScreenUpdating = True
   
    'Debug.Print "Demo-03????:" & amp; amp; endTime - startTime
    Debug.Print "It's done in: " & Timer - t & " seconds"
    Debug.Print "Time to complete = " & Timer - startTime & " seconds."
End Sub

for the second solution there is an error in the code below and also I attach screenshot

VBA Code:

        Dic2(Source2(n, 1)) = n

shknbk2 · Jan 28, 2022

Well, I can only go off of the example text you provided in the first post. Is the data you are running this on different from that or is the code giving the errors of that data?

roykana · Jan 28, 2022

shknbk2 said:
Well, I can only go off of the example text you provided in the first post. Is the data you are running this on different from that or is the code giving the errors of that data?

@shknbk2
I run according to the sample data and the code you provided the error
Below I attach the sample file link
link sample file

Marc L · Jan 28, 2022

Hi,

unclear : do you want the formulas within column E ?

If not try to well elaborate all your need …

roykana · Jan 28, 2022

Marc L said:
Hi,

unclear : do you want the formulas within column E ?
If not try to well elaborate all your need …

@Marc L
I don't want a formula, a formula just for an explanation for the desired result. So I want a little extra code in the code I posted. I definitely want the code to go fast.

shknbk2 · Jan 29, 2022

Thanks for the file. Found it. The CurrentRegion of C1 in the first Source assignment was throwing it off. Since there is data in columns A and B in your data, the CurrentRegion was changed to A1:D8 rather than C1:F6. Then, when comparing Source(n,1) later, all of the data was off. This will hopefully help for both procedures.

VBA Code:

Sub vloookupdictionary()
    Dim Rng As Range, Ds As Range, n As Long, Dic As Object, Source As Variant
    Dim i As Long
    Dim Ary As Variant
    Dim startTime As Double
    Dim endTime As Double
    Dim t
    t = Timer
    endTime = Timer
    'Dim startTime As Double
    'Dim endTime As Double
    
    Application.ScreenUpdating = False
    With Sheets("DB")
        Source = .Range("C1", .Range("C" & Rows.Count).End(xlUp)).Resize(, 4)
    End With
    Set Dic = CreateObject("scripting.dictionary")
    Dic.CompareMode = vbBinaryCompare
    For n = 2 To UBound(Source, 1)
        Dic(Source(n, 1)) = n
    Next
    
    'result in column E Sheet "selectfile"
    With Sheets("SELECTFILE")
        Ary = .Range("C2", .Range("C" & Rows.Count).End(xlUp)).Value2
        ReDim Nary(1 To UBound(Ary), 1 To 3)
        For n = 1 To UBound(Ary)
            If Dic.Exists(Ary(n, 1)) Then
                Nary(n, 1) = Source(Dic(Ary(n, 1)), 4)
            Else
                For i = 0 To Dic.Count - 1
                    If Ary(n, 1) > Dic.keys()(i) Then
                        Nary(n, 1) = Source(i + 2, 4)
                    End If
                Next i
            End If
        Next n
    End With
    With Sheets("DB")
'        Source = .Range("I1").CurrentRegion.Resize(, 4)
        Source = .Range("I1", .Range("I" & Rows.Count).End(xlUp)).Resize(, 4)
    End With
    Set Dic = CreateObject("scripting.dictionary")
    Dic.CompareMode = vbTextCompare
    For n = 2 To UBound(Source, 1)
        Dic(Source(n, 1)) = n
    Next
    With Sheets("SELECTFILE")
        Ary = .Range("A2", .Range("A" & Rows.Count).End(xlUp)).Value2
        For n = 1 To UBound(Ary)
            If Dic.Exists(Ary(n, 1)) Then
                Nary(n, 2) = Source(Dic(Ary(n, 1)), 3)
                Nary(n, 3) = Source(Dic(Ary(n, 1)), 2)
            End If
        Next n
        .Range("E2").Resize(UBound(Nary), 3).Value = Nary
    End With
    
    
    Application.ScreenUpdating = True
    
    'Debug.Print "Demo-03????:" & amp; amp; endTime - startTime
    Debug.Print "It's done in: " & Timer - t & " seconds"
    Debug.Print "Time to complete = " & Timer - startTime & " seconds."
End Sub
Sub vloookupdictionary2()
    Dim Rng As Range, Ds As Range, n As Long
    Dim Dic1 As Object, Dic2 As Object
    Dim Source1 As Variant, Source2 As Variant
    Dim i As Long
    Dim Ary1 As Variant, Ary2 As Variant
    Dim startTime As Double
    Dim endTime As Double
    Dim t
    t = Timer
    endTime = Timer
    'Dim startTime As Double
    'Dim endTime As Double
    
    Application.ScreenUpdating = False
    With Sheets("DB")
        Source1 = .Range("C1", .Range("C" & Rows.Count).End(xlUp)).Resize(, 4)
        Source2 = .Range("I1", .Range("I" & Rows.Count).End(xlUp)).Resize(, 4)
    End With
    Set Dic1 = CreateObject("scripting.dictionary")
    Set Dic2 = CreateObject("scripting.dictionary")
    Dic1.CompareMode = vbBinaryCompare
    Dic2.CompareMode = vbBinaryCompare
    For n = 2 To UBound(Source1, 1)
        Dic1(Source1(n, 1)) = n
        Dic2(Source2(n, 1)) = n
    Next
    
    'result in column E Sheet "selectfile"
    With Sheets("SELECTFILE")
        Ary1 = .Range("C2", .Range("C" & Rows.Count).End(xlUp)).Value2
        Ary2 = .Range("A2", .Range("A" & Rows.Count).End(xlUp)).Value2
        ReDim Nary(1 To UBound(Ary1), 1 To 3)
        For n = 1 To UBound(Ary1)
            If Dic1.Exists(Ary1(n, 1)) Then
                Nary(n, 1) = Source1(Dic1(Ary1(n, 1)), 4)
            Else
                For i = 0 To Dic1.Count - 1
                    If Ary1(n, 1) > Dic1.keys()(i) Then
                        Nary(n, 1) = Source1(i + 2, 4)
                    End If
                Next i
            End If
            If Dic2.Exists(Ary2(n, 1)) Then
                Nary(n, 2) = Source2(Dic2(Ary2(n, 1)), 3)
                Nary(n, 3) = Source2(Dic2(Ary2(n, 1)), 2)
            End If
        Next n
        .Range("E2").Resize(UBound(Nary), 3).Value = Nary
    End With
    Application.ScreenUpdating = True
    
    'Debug.Print "Demo-03????:" & amp; amp; endTime - startTime
    Debug.Print "It's done in: " & Timer - t & " seconds"
    Debug.Print "Time to complete = " & Timer - startTime & " seconds."
End Sub

roykana · Jan 29, 2022

shknbk2 said:

Thanks for the file. Found it. The CurrentRegion of C1 in the first Source assignment was throwing it off. Since there is data in columns A and B in your data, the CurrentRegion was changed to A1:D8 rather than C1:F6. Then, when comparing Source(n,1) later, all of the data was off. This will hopefully help for both procedures.

VBA Code:

Sub vloookupdictionary()
    Dim Rng As Range, Ds As Range, n As Long, Dic As Object, Source As Variant
    Dim i As Long
    Dim Ary As Variant
    Dim startTime As Double
    Dim endTime As Double
    Dim t
    t = Timer
    endTime = Timer
    'Dim startTime As Double
    'Dim endTime As Double
   
    Application.ScreenUpdating = False
    With Sheets("DB")
        Source = .Range("C1", .Range("C" & Rows.Count).End(xlUp)).Resize(, 4)
    End With
    Set Dic = CreateObject("scripting.dictionary")
    Dic.CompareMode = vbBinaryCompare
    For n = 2 To UBound(Source, 1)
        Dic(Source(n, 1)) = n
    Next
   
    'result in column E Sheet "selectfile"
    With Sheets("SELECTFILE")
        Ary = .Range("C2", .Range("C" & Rows.Count).End(xlUp)).Value2
        ReDim Nary(1 To UBound(Ary), 1 To 3)
        For n = 1 To UBound(Ary)
            If Dic.Exists(Ary(n, 1)) Then
                Nary(n, 1) = Source(Dic(Ary(n, 1)), 4)
            Else
                For i = 0 To Dic.Count - 1
                    If Ary(n, 1) > Dic.keys()(i) Then
                        Nary(n, 1) = Source(i + 2, 4)
                    End If
                Next i
            End If
        Next n
    End With
    With Sheets("DB")
'        Source = .Range("I1").CurrentRegion.Resize(, 4)
        Source = .Range("I1", .Range("I" & Rows.Count).End(xlUp)).Resize(, 4)
    End With
    Set Dic = CreateObject("scripting.dictionary")
    Dic.CompareMode = vbTextCompare
    For n = 2 To UBound(Source, 1)
        Dic(Source(n, 1)) = n
    Next
    With Sheets("SELECTFILE")
        Ary = .Range("A2", .Range("A" & Rows.Count).End(xlUp)).Value2
        For n = 1 To UBound(Ary)
            If Dic.Exists(Ary(n, 1)) Then
                Nary(n, 2) = Source(Dic(Ary(n, 1)), 3)
                Nary(n, 3) = Source(Dic(Ary(n, 1)), 2)
            End If
        Next n
        .Range("E2").Resize(UBound(Nary), 3).Value = Nary
    End With
   
   
    Application.ScreenUpdating = True
   
    'Debug.Print "Demo-03????:" & amp; amp; endTime - startTime
    Debug.Print "It's done in: " & Timer - t & " seconds"
    Debug.Print "Time to complete = " & Timer - startTime & " seconds."
End Sub
Sub vloookupdictionary2()
    Dim Rng As Range, Ds As Range, n As Long
    Dim Dic1 As Object, Dic2 As Object
    Dim Source1 As Variant, Source2 As Variant
    Dim i As Long
    Dim Ary1 As Variant, Ary2 As Variant
    Dim startTime As Double
    Dim endTime As Double
    Dim t
    t = Timer
    endTime = Timer
    'Dim startTime As Double
    'Dim endTime As Double
   
    Application.ScreenUpdating = False
    With Sheets("DB")
        Source1 = .Range("C1", .Range("C" & Rows.Count).End(xlUp)).Resize(, 4)
        Source2 = .Range("I1", .Range("I" & Rows.Count).End(xlUp)).Resize(, 4)
    End With
    Set Dic1 = CreateObject("scripting.dictionary")
    Set Dic2 = CreateObject("scripting.dictionary")
    Dic1.CompareMode = vbBinaryCompare
    Dic2.CompareMode = vbBinaryCompare
    For n = 2 To UBound(Source1, 1)
        Dic1(Source1(n, 1)) = n
        Dic2(Source2(n, 1)) = n
    Next
   
    'result in column E Sheet "selectfile"
    With Sheets("SELECTFILE")
        Ary1 = .Range("C2", .Range("C" & Rows.Count).End(xlUp)).Value2
        Ary2 = .Range("A2", .Range("A" & Rows.Count).End(xlUp)).Value2
        ReDim Nary(1 To UBound(Ary1), 1 To 3)
        For n = 1 To UBound(Ary1)
            If Dic1.Exists(Ary1(n, 1)) Then
                Nary(n, 1) = Source1(Dic1(Ary1(n, 1)), 4)
            Else
                For i = 0 To Dic1.Count - 1
                    If Ary1(n, 1) > Dic1.keys()(i) Then
                        Nary(n, 1) = Source1(i + 2, 4)
                    End If
                Next i
            End If
            If Dic2.Exists(Ary2(n, 1)) Then
                Nary(n, 2) = Source2(Dic2(Ary2(n, 1)), 3)
                Nary(n, 3) = Source2(Dic2(Ary2(n, 1)), 2)
            End If
        Next n
        .Range("E2").Resize(UBound(Nary), 3).Value = Nary
    End With
    Application.ScreenUpdating = True
   
    'Debug.Print "Demo-03????:" & amp; amp; endTime - startTime
    Debug.Print "It's done in: " & Timer - t & " seconds"
    Debug.Print "Time to complete = " & Timer - startTime & " seconds."
End Sub

@shknbk2

thanks for your reply. I tried it was appropriate but the result should be text or general in column E in the "selectfile" sheet because the source is not a date format so I have to add code like below or do you have other recommendations

VBA Code:

.Columns(5).NumberFormat = "@"

Marc L · Jan 29, 2022

According to your post #5 attachment I would take the obvious easy path :

VBA Code:

Sub Demo0()
    With Sheet1.Range("E2:E" & Sheet1.UsedRange.Rows.Count)
        .Formula = "=VLOOKUP(C2,Table1,4,1)"
        .Formula = .Value
    End With
End Sub

But according to your post #9 where you need column E as text

- this information was not in the initial post (as it must be !) where the picture is showing dates instead of texts ! Is is so difficult to just well explain your need ? -

this is the revamped version :

VBA Code:

Sub Demo1()
        Dim V, R&
        Application.ScreenUpdating = False
    With Sheet1.Range("E2:E" & Sheet1.UsedRange.Rows.Count)
       .Formula = "=VLOOKUP(C2,Table1,4,1)"
        V = .Value
        For R = 1 To UBound(V):  V(R, 1) = CStr(V(R, 1)):  Next
       .NumberFormat = "@"
       .Value2 = V
    End With
        Application.ScreenUpdating = True
End Sub

vlookup dictionary approximate match

roykana

Active Member

Excel Facts

shknbk2

Well-known Member

roykana

Active Member

Attachments

shknbk2

Well-known Member

roykana

Active Member

Marc L

Banned User

roykana

Active Member

shknbk2

Well-known Member

roykana

Active Member

Marc L

Banned User

Similar threads

Forum statistics

Share this page

Cell Formulas
Range	Formula
E2:E6	E2	=VLOOKUP(C2,Table1,4,1)

vlookup dictionary approximate match

Active Member

Excel Facts

Well-known Member

Active Member

Attachments

Well-known Member

Active Member

Banned User

Active Member

Well-known Member

Active Member

Banned User

Similar threads

Forum statistics

Share this page

We've detected that you are using an adblocker.

Which adblocker are you using?

Disable AdBlock

Disable AdBlock Plus

Disable uBlock Origin

Disable uBlock