Problem in vba vlookup

R

roykana

Active Member
Joined
Mar 8, 2018
Messages
311
Office Version
  1. 2010
Platform
  1. Windows
Dear All Master,

The problem I mean is as follows :

1. I want to modify the vba code because it takes too long/very slow to vlookup in VBA code so I want a very fast vba code
2. I want to set from column I2 and J2 in the sheet "GSD" and I mark it in yellow
3. I want vba code which is automatic like "Worksheet Change" or if any other code
this is my link : SALES ALL IN ONE 2016-NOW-vba - Copy.xlsm
file
VBA Code: 
Option Explicit
Sub multivlookupV2()
 OptimizeVBA True
 Dim startTime As Single, endTime As Single
    startTime = Timer
 With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
        .EnableEvents = False
    End With
    ActiveSheet.DisplayPageBreaks = False
 With Range(Cells(2, 9), Cells(2, 9).End(xlDown))
       .FormulaR1C1 = "=IF([@ITM]=""JASA SERVICE"",""NO"",IF([@DEPT]=""BOJ"",VLOOKUP([@ITM],MASTER_ITEM_NO,4,0),IF([@DEPT]=""M18"",VLOOKUP([@ITM],MASTER_ITEM_NO[[M18]:[ITEM NO NEW]],3,0),IF([@DEPT]=""MD2"",VLOOKUP([@ITM],MASTER_ITEM_NO[[MD2]:[ITEM NO NEW]],2,0),IF([@DEPT]=""M07"",VLOOKUP([@ITM],MASTER_ITEM_NO[[M18]:[ITEM NO NEW]],3,0))))))"
       .Value = .Value
 End With
  With Range(Cells(2, 10), Cells(2, 10).End(xlDown))
       .FormulaR1C1 = "=VLOOKUP([@PNM],GSG,9,0)"
       .Value = .Value
 End With
 With Application
        .EnableEvents = True
        .Calculation = xlCalculationAutomatic
        .ScreenUpdating = True
    End With
    endTime = Timer
    Debug.Print (endTime - startTime) & " seconds have passed [VBA]"
    OptimizeVBA False
 End Sub
 Sub OptimizeVBA(isOn As Boolean)
    Application.Calculation = IIf(isOn, xlCalculationManual, xlCalculationAutomatic)
    Application.EnableEvents = Not (isOn)
    Application.ScreenUpdating = Not (isOn)
    ActiveSheet.DisplayPageBreaks = Not (isOn)
End Sub
Thanks
Roykana
 
Sort by date Sort by votes
Akuini said:
I don't understand your words.
Do you mean you don't need the automatic code?
Click to expand...

I need automatic code, I think with point 3 (3. I want vba code which is automatic like "Worksheet Change" or if any other code) it will make the process take longer. If this doesn't interfere with the process or make it take longer then point 3 can be done. Sorry if I got the wrong perception
Akuini said:
As for your code in post #13, to fill all rows.
Does it work?
How long did it take?
Click to expand...
for postal vba code # 13 it doesn't work yet because it has to be modified.
Akuini said:
How long is the acceptable processing time?
Click to expand...

I want 60 seconds
Akuini said:
But I don't understand why 2-3 minutes processing time isn't acceptable for you. You only need to run it once.
Click to expand...

I think the code posted # 13 is faster if it has been modified
 
Upvote 0

Excel Facts

Why does 9 mean SUM in SUBTOTAL?
It is because Sum is the 9th alphabetically in Average, Count, CountA, Max, Min, Product, StDev.S, StDev.P, Sum, VAR.S, VAR.P.
I want 60 seconds
Click to expand...

Try this code to fill in all rows in col I:J. Just run Sub toCall.
I put the result in col N:O, you may change that.
Debug print result:
Rich (BB code): 
It's done in: 10,83203 seconds
It's done in: 3,730469 seconds

so it took about 15 seconds on my PC.

VBA Code: 
Sub toCall()
    Call itemNo
    Call toNama3
End Sub


Sub itemNo()
Dim i As Long, j As Long
Dim va, vb, vc, vd, t
Dim ws1 As Worksheet

t = Timer
Set ws1 = Sheets("GSD")
With ws1
        va = .Range("B2:G" & .Cells(.Rows.Count, "B").End(xlUp).Row)
End With

ReDim vb(1 To UBound(va, 1), 1 To 1)
ReDim vd(1 To UBound(va, 1), 1 To 1)


With Sheets("MASTER_ITEM_NO")
    vc = .Range("A1:D" & .Cells(.Rows.Count, "A").End(xlUp).Row)
End With

For i = 1 To UBound(va, 1)
    vb(i, 1) = va(i, 6) & "|" & va(i, 1)
Next


Set d = CreateObject("scripting.dictionary")
d.CompareMode = vbTextCompare
x = Split("BOJ,M18,MD2", ",")
For j = 1 To 3
    For i = 1 To UBound(vc, 1)
        d(x(j - 1) & "|" & vc(i, j)) = vc(i, 4)
    Next
Next

For i = 1 To UBound(vb, 1)

        If d.Exists(vb(i, 1)) Then
            vd(i, 1) = d(vb(i, 1))
        End If
Next

'put the result
ws1.Range("N2").Resize(UBound(vd, 1), 1) = vd

Debug.Print "It's done in: " & Timer - t & " seconds"
End Sub

Sub toNama3()
Dim i As Long, j As Long, n As Long
Dim va, vb, vc, vd, t
Dim ws1 As Worksheet

t = Timer

Set ws1 = Sheets("GSD")
With ws1
    va = .Range("A2", .Cells(.Rows.Count, "A").End(xlUp))
End With

ReDim vb(1 To UBound(va, 1), 1 To 1)

With Sheets("GSG")
    n = .Range("A" & .Rows.Count).End(xlUp).Row
    vc = .Range("A1:A" & n)
    vd = .Range("I1:I" & n)
End With

vb(1, 1) = ws1.Range("J1")
q = 1

Set d = CreateObject("scripting.dictionary")
d.CompareMode = vbTextCompare
For i = 1 To UBound(vc, 1)
    d(vc(i, 1)) = vd(i, 1)
Next

For i = 1 To UBound(va, 1)

        If d.Exists(va(i, 1)) Then
            vb(i, 1) = d(va(i, 1))
        End If
Next

ws1.Range("O2").Resize(UBound(vb, 1), 1) = vb

Debug.Print "It's done in: " & Timer - t & " seconds"

End Sub


As for the automatic code. I haven't written it yet.
What is the data entry sequence? Do you enter data from col A to H in order? If yes then we should use col G to trigger the macro.
 
Upvote 0
Akuini said:
Try this code to fill in all rows in col I:J. Just run Sub toCall.
I put the result in col N:O, you may change that.
Debug print result:
Rich (BB code): 
It's done in: 10,83203 seconds
It's done in: 3,730469 seconds

so it took about 15 seconds on my PC.

VBA Code: 
Sub toCall()
    Call itemNo
    Call toNama3
End Sub


Sub itemNo()
Dim i As Long, j As Long
Dim va, vb, vc, vd, t
Dim ws1 As Worksheet

t = Timer
Set ws1 = Sheets("GSD")
With ws1
        va = .Range("B2:G" & .Cells(.Rows.Count, "B").End(xlUp).Row)
End With

ReDim vb(1 To UBound(va, 1), 1 To 1)
ReDim vd(1 To UBound(va, 1), 1 To 1)


With Sheets("MASTER_ITEM_NO")
    vc = .Range("A1:D" & .Cells(.Rows.Count, "A").End(xlUp).Row)
End With

For i = 1 To UBound(va, 1)
    vb(i, 1) = va(i, 6) & "|" & va(i, 1)
Next


Set d = CreateObject("scripting.dictionary")
d.CompareMode = vbTextCompare
x = Split("BOJ,M18,MD2", ",")
For j = 1 To 3
    For i = 1 To UBound(vc, 1)
        d(x(j - 1) & "|" & vc(i, j)) = vc(i, 4)
    Next
Next

For i = 1 To UBound(vb, 1)

        If d.Exists(vb(i, 1)) Then
            vd(i, 1) = d(vb(i, 1))
        End If
Next

'put the result
ws1.Range("N2").Resize(UBound(vd, 1), 1) = vd

Debug.Print "It's done in: " & Timer - t & " seconds"
End Sub

Sub toNama3()
Dim i As Long, j As Long, n As Long
Dim va, vb, vc, vd, t
Dim ws1 As Worksheet

t = Timer

Set ws1 = Sheets("GSD")
With ws1
    va = .Range("A2", .Cells(.Rows.Count, "A").End(xlUp))
End With

ReDim vb(1 To UBound(va, 1), 1 To 1)

With Sheets("GSG")
    n = .Range("A" & .Rows.Count).End(xlUp).Row
    vc = .Range("A1:A" & n)
    vd = .Range("I1:I" & n)
End With

vb(1, 1) = ws1.Range("J1")
q = 1

Set d = CreateObject("scripting.dictionary")
d.CompareMode = vbTextCompare
For i = 1 To UBound(vc, 1)
    d(vc(i, 1)) = vd(i, 1)
Next

For i = 1 To UBound(va, 1)

        If d.Exists(va(i, 1)) Then
            vb(i, 1) = d(va(i, 1))
        End If
Next

ws1.Range("O2").Resize(UBound(vb, 1), 1) = vb

Debug.Print "It's done in: " & Timer - t & " seconds"

End Sub


As for the automatic code. I haven't written it yet.
What is the data entry sequence? Do you enter data from col A to H in order? If yes then we should use col G to trigger the macro.
Click to expand...
Yes. Speed is subjective depends on hardware like processing power and available RAM. Also based on my experience running same code on Excel 2003 can easily cut execution time more than 50%.
 
Upvote 0
Akuini said:
Try this code to fill in all rows in col I:J. Just run Sub toCall.
I put the result in col N:O, you may change that.
Debug print result:
Rich (BB code): 
It's done in: 10,83203 seconds
It's done in: 3,730469 seconds

so it took about 15 seconds on my PC.

VBA Code: 
Sub toCall()
    Call itemNo
    Call toNama3
End Sub


Sub itemNo()
Dim i As Long, j As Long
Dim va, vb, vc, vd, t
Dim ws1 As Worksheet

t = Timer
Set ws1 = Sheets("GSD")
With ws1
        va = .Range("B2:G" & .Cells(.Rows.Count, "B").End(xlUp).Row)
End With

ReDim vb(1 To UBound(va, 1), 1 To 1)
ReDim vd(1 To UBound(va, 1), 1 To 1)


With Sheets("MASTER_ITEM_NO")
    vc = .Range("A1:D" & .Cells(.Rows.Count, "A").End(xlUp).Row)
End With

For i = 1 To UBound(va, 1)
    vb(i, 1) = va(i, 6) & "|" & va(i, 1)
Next


Set d = CreateObject("scripting.dictionary")
d.CompareMode = vbTextCompare
x = Split("BOJ,M18,MD2", ",")
For j = 1 To 3
    For i = 1 To UBound(vc, 1)
        d(x(j - 1) & "|" & vc(i, j)) = vc(i, 4)
    Next
Next

For i = 1 To UBound(vb, 1)

        If d.Exists(vb(i, 1)) Then
            vd(i, 1) = d(vb(i, 1))
        End If
Next

'put the result
ws1.Range("N2").Resize(UBound(vd, 1), 1) = vd

Debug.Print "It's done in: " & Timer - t & " seconds"
End Sub

Sub toNama3()
Dim i As Long, j As Long, n As Long
Dim va, vb, vc, vd, t
Dim ws1 As Worksheet

t = Timer

Set ws1 = Sheets("GSD")
With ws1
    va = .Range("A2", .Cells(.Rows.Count, "A").End(xlUp))
End With

ReDim vb(1 To UBound(va, 1), 1 To 1)

With Sheets("GSG")
    n = .Range("A" & .Rows.Count).End(xlUp).Row
    vc = .Range("A1:A" & n)
    vd = .Range("I1:I" & n)
End With

vb(1, 1) = ws1.Range("J1")
q = 1

Set d = CreateObject("scripting.dictionary")
d.CompareMode = vbTextCompare
For i = 1 To UBound(vc, 1)
    d(vc(i, 1)) = vd(i, 1)
Next

For i = 1 To UBound(va, 1)

        If d.Exists(va(i, 1)) Then
            vb(i, 1) = d(va(i, 1))
        End If
Next

ws1.Range("O2").Resize(UBound(vb, 1), 1) = vb

Debug.Print "It's done in: " & Timer - t & " seconds"

End Sub


As for the automatic code. I haven't written it yet.
What is the data entry sequence? Do you enter data from col A to H in order? If yes then we should use col G to trigger the macro.
Click to expand...
Dear Mr. Akuini
Thank you very much this is really perfect. But I have a little problem.
Problem1 & Problem 2, I attach screenshots

Problem1 & Problem 2 It should be in column p2 empty in sheet gsd and take value in ae2 in sheet gsg.
if using a formula for problem 1&2 : "=VLOOKUP(A2,GSG_ALL[[PNM]:[%dis]],29,0)"
Problem 3 : If in the gsd sheet in column B there is the word "Jasa Service", then the result is "No". And for Dept. "M07" the result is the same as "M18".

if using a formula for problem 3 : "=IF(B2="JASA SERVICE","NO",IF(G2="BOJ",VLOOKUP(B2,MASTER_ITEM_NO,4,0),IF(G2="M18",VLOOKUP(B2,MASTER_ITEM_NO[[M18]:[ITEM NO NEW]],3,0),IF(G2="M07",VLOOKUP(B2,MASTER_ITEM_NO[[M18]:[ITEM NO NEW]],3,0),IF(G2="MD2",VLOOKUP(B2,MASTER_ITEM_NO[[MD2]:[ITEM NO NEW]],2,0))))))"

Thanks

Roykana
 

Attachments

  • problem1.PNG
    problem1.PNG
    9.7 KB · Views: 9
  • problem2.PNG
    problem2.PNG
    3.5 KB · Views: 10
  • Problem3.PNG
    Problem3.PNG
    19.5 KB · Views: 9
Upvote 0
roykana said:
Dear Mr. Akuini
Thank you very much this is really perfect. But I have a little problem.
Problem1 & Problem 2, I attach screenshots

Problem1 & Problem 2 It should be in column p2 empty in sheet gsd and take value in ae2 in sheet gsg.
if using a formula for problem 1&2 : "=VLOOKUP(A2,GSG_ALL[[PNM]:[%dis]],29,0)"
Problem 3 : If in the gsd sheet in column B there is the word "Jasa Service", then the result is "No". And for Dept. "M07" the result is the same as "M18".

if using a formula for problem 3 : "=IF(B2="JASA SERVICE","NO",IF(G2="BOJ",VLOOKUP(B2,MASTER_ITEM_NO,4,0),IF(G2="M18",VLOOKUP(B2,MASTER_ITEM_NO[[M18]:[ITEM NO NEW]],3,0),IF(G2="M07",VLOOKUP(B2,MASTER_ITEM_NO[[M18]:[ITEM NO NEW]],3,0),IF(G2="MD2",VLOOKUP(B2,MASTER_ITEM_NO[[MD2]:[ITEM NO NEW]],2,0))))))"

Thanks

Roykana
Click to expand...
VBA Code: 
Sub toCall()
    Call itemNo
    Call toNama3
End Sub
Sub itemNo()
Dim i As Long, j As Long
Dim va, vb, vc, vd, t
Dim ws1 As Worksheet

t = Timer
Set ws1 = Sheets("GSD")
With ws1
        va = .Range("B2:G" & .Cells(.Rows.Count, "B").End(xlUp).Row)
End With

ReDim vb(1 To UBound(va, 1), 1 To 1)
ReDim vd(1 To UBound(va, 1), 1 To 1)


With Sheets("MASTER_ITEM_NO")
    vc = .Range("A1:D" & .Cells(.Rows.Count, "A").End(xlUp).Row)
End With

For i = 1 To UBound(va, 1)
    vb(i, 1) = va(i, 6) & "|" & va(i, 1)
Next


Set d = CreateObject("scripting.dictionary")
d.CompareMode = vbTextCompare
x = Split("BOJ,M18,MD2", ",")
For j = 1 To 3
    For i = 1 To UBound(vc, 1)
        d(x(j - 1) & "|" & vc(i, j)) = vc(i, 4)
    Next
Next

For i = 1 To UBound(vb, 1)

        If d.Exists(vb(i, 1)) Then
            vd(i, 1) = d(vb(i, 1))
        End If
Next

'put the result
ws1.Range("O2").Resize(UBound(vd, 1), 1) = vd

Debug.Print "It's done in: " & Timer - t & " seconds"
End Sub

Sub toNama3()
Dim i As Long, j As Long, n As Long
Dim va, vb, vc, vd, t
Dim ws1 As Worksheet

t = Timer

Set ws1 = Sheets("GSD")
With ws1
    va = .Range("A2", .Cells(.Rows.Count, "A").End(xlUp))
End With

ReDim vb(1 To UBound(va, 1), 1 To 1)

With Sheets("GSG")
    n = .Range("A" & .Rows.Count).End(xlUp).Row
    vc = .Range("A1:A" & n)
    vd = .Range("AE1:AE" & n)
End With

vb(1, 1) = ws1.Range("P1")
q = 1

Set d = CreateObject("scripting.dictionary")
d.CompareMode = vbTextCompare
For i = 1 To UBound(vc, 1)
    d(vc(i, 1)) = vd(i, 1)
Next

For i = 1 To UBound(va, 1)

        If d.Exists(va(i, 1)) Then
            vb(i, 1) = d(va(i, 1))
        End If
Next

ws1.Range("P2").Resize(UBound(vb, 1), 1) = vb

Debug.Print "It's done in: " & Timer - t & " seconds"

End Sub
 
Upvote 0
roykana said:
VBA Code: 
Sub toCall()
    Call itemNo
    Call toNama3
End Sub
Sub itemNo()
Dim i As Long, j As Long
Dim va, vb, vc, vd, t
Dim ws1 As Worksheet

t = Timer
Set ws1 = Sheets("GSD")
With ws1
        va = .Range("B2:G" & .Cells(.Rows.Count, "B").End(xlUp).Row)
End With

ReDim vb(1 To UBound(va, 1), 1 To 1)
ReDim vd(1 To UBound(va, 1), 1 To 1)


With Sheets("MASTER_ITEM_NO")
    vc = .Range("A1:D" & .Cells(.Rows.Count, "A").End(xlUp).Row)
End With

For i = 1 To UBound(va, 1)
    vb(i, 1) = va(i, 6) & "|" & va(i, 1)
Next


Set d = CreateObject("scripting.dictionary")
d.CompareMode = vbTextCompare
x = Split("BOJ,M18,MD2", ",")
For j = 1 To 3
    For i = 1 To UBound(vc, 1)
        d(x(j - 1) & "|" & vc(i, j)) = vc(i, 4)
    Next
Next

For i = 1 To UBound(vb, 1)

        If d.Exists(vb(i, 1)) Then
            vd(i, 1) = d(vb(i, 1))
        End If
Next

'put the result
ws1.Range("O2").Resize(UBound(vd, 1), 1) = vd

Debug.Print "It's done in: " & Timer - t & " seconds"
End Sub

Sub toNama3()
Dim i As Long, j As Long, n As Long
Dim va, vb, vc, vd, t
Dim ws1 As Worksheet

t = Timer

Set ws1 = Sheets("GSD")
With ws1
    va = .Range("A2", .Cells(.Rows.Count, "A").End(xlUp))
End With

ReDim vb(1 To UBound(va, 1), 1 To 1)

With Sheets("GSG")
    n = .Range("A" & .Rows.Count).End(xlUp).Row
    vc = .Range("A1:A" & n)
    vd = .Range("AE1:AE" & n)
End With

vb(1, 1) = ws1.Range("P1")
q = 1

Set d = CreateObject("scripting.dictionary")
d.CompareMode = vbTextCompare
For i = 1 To UBound(vc, 1)
    d(vc(i, 1)) = vd(i, 1)
Next

For i = 1 To UBound(va, 1)

        If d.Exists(va(i, 1)) Then
            vb(i, 1) = d(va(i, 1))
        End If
Next

ws1.Range("P2").Resize(UBound(vb, 1), 1) = vb

Debug.Print "It's done in: " & Timer - t & " seconds"

End Sub
Click to expand...
Dear Mr. Akuini
You provide vba code perfectly.
I try to use the vba code in the actual data there is something that doesn't match. The results column o & p that should be same in column q and R are marked in yellow on the GSD sheet
My File Link : SALES ALL IN ONE 2016-NOW-sample..xlsm
File
For automatic code problems after solving a few of these problems.

Sorry if there is a miscommunication or misunderstanding because I was not focused

Thanks
Roykana
VBA Code: 
Sub toCall()
    Call itemNo
    Call toNama3
End Sub
Sub itemNo()
Dim i As Long, j As Long
Dim va, vb, vc, vd, t
Dim ws1 As Worksheet

t = Timer
Set ws1 = Sheets("GSD")
With ws1
        va = .Range("B2:G" & .Cells(.Rows.Count, "B").End(xlUp).Row)
End With

ReDim vb(1 To UBound(va, 1), 1 To 1)
ReDim vd(1 To UBound(va, 1), 1 To 1)


With Sheets("MASTER_ITEM_NO")
    vc = .Range("A1:D" & .Cells(.Rows.Count, "A").End(xlUp).Row)
End With

For i = 1 To UBound(va, 1)
    vb(i, 1) = va(i, 6) & "|" & va(i, 1)
Next


Set d = CreateObject("scripting.dictionary")
d.CompareMode = vbTextCompare
x = Split("BOJ,M18,MD2", ",")
For j = 1 To 3
    For i = 1 To UBound(vc, 1)
        d(x(j - 1) & "|" & vc(i, j)) = vc(i, 4)
    Next
Next

For i = 1 To UBound(vb, 1)

        If d.Exists(vb(i, 1)) Then
            vd(i, 1) = d(vb(i, 1))
        End If
Next

'put the result
ws1.Range("O2").Resize(UBound(vd, 1), 1) = vd

Debug.Print "It's done in: " & Timer - t & " seconds"
End Sub

Sub toNama3()
Dim i As Long, j As Long, n As Long
Dim va, vb, vc, vd, t
Dim ws1 As Worksheet

t = Timer

Set ws1 = Sheets("GSD")
With ws1
    va = .Range("A2", .Cells(.Rows.Count, "A").End(xlUp))
End With

ReDim vb(1 To UBound(va, 1), 1 To 1)

With Sheets("GSG")
    n = .Range("A" & .Rows.Count).End(xlUp).Row
    vc = .Range("A1:A" & n)
    vd = .Range("AE1:AE" & n)
End With

vb(1, 1) = ws1.Range("P1")
q = 1

Set d = CreateObject("scripting.dictionary")
d.CompareMode = vbTextCompare
For i = 1 To UBound(vc, 1)
    d(vc(i, 1)) = vd(i, 1)
Next

For i = 1 To UBound(va, 1)

        If d.Exists(va(i, 1)) Then
            vb(i, 1) = d(va(i, 1))
        End If
Next

ws1.Range("P2").Resize(UBound(vb, 1), 1) = vb

Debug.Print "It's done in: " & Timer - t & " seconds"

End Sub
 
Upvote 0
I have another look this morning after my 1st attempt.

For large data like this, search from memory is way faster. Since it is simple table search, I'm using dictionary to create table. the timer shows 19.98047s on my PC which is old i5-6500 ?

I see that you have actual data data which is different column than your previous example. If column is not fixed, probably better to have it automatically search for right column. I was thinking of using array but not sure if it would be significantly faster (or slower). Probably late since I have half day course to attend at 9am

Here is the code based on old data

VBA Code: 
Sub QuickSearch1()

Dim eRowGSD&, eRowGSG&, eRowMIN&
Dim str1$, str2$, str3$, str4$
Dim cell As Range
Dim wb As Workbook
Dim wsGSD As Worksheet, wsMIN As Worksheet, wsGSG As Worksheet
Dim Dict1 As Object, Dict2 As Object, Dict3 As Object, Dict4 As Object
Dim startTime As Single, endTime As Single

OptimizeVBA True
 
Set wb = ActiveWorkbook
Set wsGSD = wb.Sheets("GSD")
Set wsMIN = wb.Sheets("MASTER_ITEM_NO")
Set wsGSG = wb.Sheets("GSG")

eRowGSD = wsGSD.Range("G" & wsGSD.Cells.Rows.Count).End(xlUp).Row
eRowMIN = wsMIN.Range("A" & wsGSG.Cells.Rows.Count).End(xlUp).Row
eRowGSG = wsGSG.Range("G" & wsGSG.Cells.Rows.Count).End(xlUp).Row

startTime = Timer

Set Dict1 = CreateObject("Scripting.Dictionary")
Set Dict2 = CreateObject("Scripting.Dictionary")
Set Dict3 = CreateObject("Scripting.Dictionary")
Set Dict4 = CreateObject("Scripting.Dictionary")

With wsMIN
    For Each cell In .Range("A2", "A" & eRowMIN)
        str1 = .Range("A" & cell.Row)
        str2 = .Range("B" & cell.Row)
        str3 = .Range("C" & cell.Row)
        Dict1.Add str1, cell.Row
        Dict2.Add str2, cell.Row
        Dict3.Add str3, cell.Row
    Next
End With
With wsGSG
    For Each cell In .Range("A2", "A" & eRowGSG)
        str4 = .Range("A" & cell.Row)
        Dict4.Add str4, cell.Row
    Next
End With

With wsGSD
    For Each cell In .Range("G2", "G" & eRowGSD)
        str1 = .Range("A" & cell.Row)
        str2 = .Range("B" & cell.Row)
        Select Case cell
            Case "BOJ"
                .Range("I" & cell.Row) = wsMIN.Range("D" & Dict1(str2))
            Case "M18", "M07"
                .Range("I" & cell.Row) = wsMIN.Range("D" & Dict2(str2))
            Case "MD2"
                .Range("I" & cell.Row) = wsMIN.Range("D" & Dict3(str2))
        End Select
        .Range("J" & cell.Row) = wsGSG.Range("I" & Dict4(str1))
    Next
End With
 
endTime = Timer
Debug.Print (endTime - startTime) & " seconds have passed [VBA]"
OptimizeVBA False

End Sub

 Sub OptimizeVBA(isOn As Boolean)
    Application.Calculation = IIf(isOn, xlCalculationManual, xlCalculationAutomatic)
    Application.EnableEvents = Not (isOn)
    Application.ScreenUpdating = Not (isOn)
    ActiveSheet.DisplayPageBreaks = Not (isOn)
End Sub
 
Upvote 0
Ok, I amended the code:
VBA Code: 
Sub toCall()
    Call itemNo
    Call toNama3
End Sub
Sub itemNo()
Dim i As Long, j As Long
Dim va, vb, vc, vd, t
Dim ws1 As Worksheet

t = Timer
Set ws1 = Sheets("GSD")
With ws1
        va = .Range("B2:G" & .Cells(.Rows.Count, "B").End(xlUp).Row)
End With



For i = 1 To UBound(va, 1)
    If va(i, 6) = "M07" Then va(i, 6) = "M18"
Next

ReDim vb(1 To UBound(va, 1), 1 To 1)
ReDim vd(1 To UBound(va, 1), 1 To 1)


With Sheets("MASTER_ITEM_NO")
    vc = .Range("A1:D" & .Cells(.Rows.Count, "A").End(xlUp).Row)
End With

For i = 1 To UBound(va, 1)
    vb(i, 1) = va(i, 6) & "|" & va(i, 1)
Next


Set d = CreateObject("scripting.dictionary")
d.CompareMode = vbTextCompare
x = Split("BOJ,M18,MD2", ",")
For j = 1 To 3
    For i = 1 To UBound(vc, 1)
        d(x(j - 1) & "|" & vc(i, j)) = vc(i, 4)
    Next
Next

For i = 1 To UBound(vb, 1)

        If d.Exists(vb(i, 1)) Then
            vd(i, 1) = d(vb(i, 1))
        Else
            If va(i, 1) = "JASA SERVICE" Then vd(i, 1) = "NO"
        End If
Next

'put the result
ws1.Range("O2").Resize(UBound(vd, 1), 1) = vd

Debug.Print "It's done in: " & Timer - t & " seconds"
End Sub

Sub toNama3()
Dim i As Long, j As Long, n As Long
Dim va, vb, vc, vd, t
Dim ws1 As Worksheet

t = Timer

Set ws1 = Sheets("GSD")
With ws1
    va = .Range("A2", .Cells(.Rows.Count, "A").End(xlUp))
End With

ReDim vb(1 To UBound(va, 1), 1 To 1)

With Sheets("GSG")
    n = .Range("C" & .Rows.Count).End(xlUp).Row
    vc = .Range("C1:C" & n)
    vd = .Range("AE1:AE" & n)
End With

q = 1

Set d = CreateObject("scripting.dictionary")
d.CompareMode = vbTextCompare
For i = 1 To UBound(vc, 1)
    d(vc(i, 1)) = vd(i, 1)
Next

For i = 1 To UBound(va, 1)

        If d.Exists(va(i, 1)) Then
            vb(i, 1) = d(va(i, 1))
        End If
Next

ws1.Range("P2").Resize(UBound(vb, 1), 1) = vb

Debug.Print "It's done in: " & Timer - t & " seconds"

End Sub

As for the automatic code:
Automatic code is a bit complicated to use in this scenario. So instead of automatic code it's better to use formula to enter new data. The reason you don't want to use formula is because it slows down the sheet due to 300K+ rows of data. But after you run the above macro to fill in all rows without formula then there are no formula. So for entering new data, using formula won't slow down the sheet.
 
Upvote 0
Solution
Zot said:
I have another look this morning after my 1st attempt.

For large data like this, search from memory is way faster. Since it is simple table search, I'm using dictionary to create table. the timer shows 19.98047s on my PC which is old i5-6500 ?

I see that you have actual data data which is different column than your previous example. If column is not fixed, probably better to have it automatically search for right column. I was thinking of using array but not sure if it would be significantly faster (or slower). Probably late since I have half day course to attend at 9am

Here is the code based on old data

VBA Code: 
Sub QuickSearch1()

Dim eRowGSD&, eRowGSG&, eRowMIN&
Dim str1$, str2$, str3$, str4$
Dim cell As Range
Dim wb As Workbook
Dim wsGSD As Worksheet, wsMIN As Worksheet, wsGSG As Worksheet
Dim Dict1 As Object, Dict2 As Object, Dict3 As Object, Dict4 As Object
Dim startTime As Single, endTime As Single

OptimizeVBA True

Set wb = ActiveWorkbook
Set wsGSD = wb.Sheets("GSD")
Set wsMIN = wb.Sheets("MASTER_ITEM_NO")
Set wsGSG = wb.Sheets("GSG")

eRowGSD = wsGSD.Range("G" & wsGSD.Cells.Rows.Count).End(xlUp).Row
eRowMIN = wsMIN.Range("A" & wsGSG.Cells.Rows.Count).End(xlUp).Row
eRowGSG = wsGSG.Range("G" & wsGSG.Cells.Rows.Count).End(xlUp).Row

startTime = Timer

Set Dict1 = CreateObject("Scripting.Dictionary")
Set Dict2 = CreateObject("Scripting.Dictionary")
Set Dict3 = CreateObject("Scripting.Dictionary")
Set Dict4 = CreateObject("Scripting.Dictionary")

With wsMIN
    For Each cell In .Range("A2", "A" & eRowMIN)
        str1 = .Range("A" & cell.Row)
        str2 = .Range("B" & cell.Row)
        str3 = .Range("C" & cell.Row)
        Dict1.Add str1, cell.Row
        Dict2.Add str2, cell.Row
        Dict3.Add str3, cell.Row
    Next
End With
With wsGSG
    For Each cell In .Range("A2", "A" & eRowGSG)
        str4 = .Range("A" & cell.Row)
        Dict4.Add str4, cell.Row
    Next
End With

With wsGSD
    For Each cell In .Range("G2", "G" & eRowGSD)
        str1 = .Range("A" & cell.Row)
        str2 = .Range("B" & cell.Row)
        Select Case cell
            Case "BOJ"
                .Range("I" & cell.Row) = wsMIN.Range("D" & Dict1(str2))
            Case "M18", "M07"
                .Range("I" & cell.Row) = wsMIN.Range("D" & Dict2(str2))
            Case "MD2"
                .Range("I" & cell.Row) = wsMIN.Range("D" & Dict3(str2))
        End Select
        .Range("J" & cell.Row) = wsGSG.Range("I" & Dict4(str1))
    Next
End With

endTime = Timer
Debug.Print (endTime - startTime) & " seconds have passed [VBA]"
OptimizeVBA False

End Sub

Sub OptimizeVBA(isOn As Boolean)
    Application.Calculation = IIf(isOn, xlCalculationManual, xlCalculationAutomatic)
    Application.EnableEvents = Not (isOn)
    Application.ScreenUpdating = Not (isOn)
    ActiveSheet.DisplayPageBreaks = Not (isOn)
End Sub
Click to expand...
Mr. Zot,


Thank you for the code vba but the vba code is still the fastest from Mr. Akuini.

Thanks

Roykana
 

Attachments

  • Result from vba kode (Mr. Akuini) .PNG
    Result from vba kode (Mr. Akuini) .PNG
    2.7 KB · Views: 15
Upvote 0
Akuini said:
Ok, I amended the code:
VBA Code: 
Sub toCall()
    Call itemNo
    Call toNama3
End Sub
Sub itemNo()
Dim i As Long, j As Long
Dim va, vb, vc, vd, t
Dim ws1 As Worksheet

t = Timer
Set ws1 = Sheets("GSD")
With ws1
        va = .Range("B2:G" & .Cells(.Rows.Count, "B").End(xlUp).Row)
End With



For i = 1 To UBound(va, 1)
    If va(i, 6) = "M07" Then va(i, 6) = "M18"
Next

ReDim vb(1 To UBound(va, 1), 1 To 1)
ReDim vd(1 To UBound(va, 1), 1 To 1)


With Sheets("MASTER_ITEM_NO")
    vc = .Range("A1:D" & .Cells(.Rows.Count, "A").End(xlUp).Row)
End With

For i = 1 To UBound(va, 1)
    vb(i, 1) = va(i, 6) & "|" & va(i, 1)
Next


Set d = CreateObject("scripting.dictionary")
d.CompareMode = vbTextCompare
x = Split("BOJ,M18,MD2", ",")
For j = 1 To 3
    For i = 1 To UBound(vc, 1)
        d(x(j - 1) & "|" & vc(i, j)) = vc(i, 4)
    Next
Next

For i = 1 To UBound(vb, 1)

        If d.Exists(vb(i, 1)) Then
            vd(i, 1) = d(vb(i, 1))
        Else
            If va(i, 1) = "JASA SERVICE" Then vd(i, 1) = "NO"
        End If
Next

'put the result
ws1.Range("O2").Resize(UBound(vd, 1), 1) = vd

Debug.Print "It's done in: " & Timer - t & " seconds"
End Sub

Sub toNama3()
Dim i As Long, j As Long, n As Long
Dim va, vb, vc, vd, t
Dim ws1 As Worksheet

t = Timer

Set ws1 = Sheets("GSD")
With ws1
    va = .Range("A2", .Cells(.Rows.Count, "A").End(xlUp))
End With

ReDim vb(1 To UBound(va, 1), 1 To 1)

With Sheets("GSG")
    n = .Range("C" & .Rows.Count).End(xlUp).Row
    vc = .Range("C1:C" & n)
    vd = .Range("AE1:AE" & n)
End With

q = 1

Set d = CreateObject("scripting.dictionary")
d.CompareMode = vbTextCompare
For i = 1 To UBound(vc, 1)
    d(vc(i, 1)) = vd(i, 1)
Next

For i = 1 To UBound(va, 1)

        If d.Exists(va(i, 1)) Then
            vb(i, 1) = d(va(i, 1))
        End If
Next

ws1.Range("P2").Resize(UBound(vb, 1), 1) = vb

Debug.Print "It's done in: " & Timer - t & " seconds"

End Sub

As for the automatic code:
Automatic code is a bit complicated to use in this scenario. So instead of automatic code it's better to use formula to enter new data. The reason you don't want to use formula is because it slows down the sheet due to 300K+ rows of data. But after you run the above macro to fill in all rows without formula then there are no formula. So for entering new data, using formula won't slow down the sheet.
Click to expand...
Dear Mr. Akuini,

Thank you for the code you provided. It went perfectly.

To automatically code, so the data comes from the application database that I query via Excel. So I want to get data updates so I use refresh all.

Thanks

Roykana
 
Upvote 0
You must log in or register to reply here.

Similar threads

Guna13
  • Question Question
How to Efficient way for create Multiple Workbooks
Replies
1
Views
391
Guna13
Guna13
E
  • Question Question
Trying to use a month name in my VLookup
Replies
2
Views
346
Eric Penfold
E
R
  • Solved
Import multi dat files in vba run-time error 13
2 3
Replies
25
Views
2K
Marc L
Marc L
D
  • Question Question
Vlookup VBA returning Blank Values
Replies
2
Views
992
Fluff
Fluff
D
  • Locked
  • Question Question
VBA Vlookup Code only returning first 62 values
Replies
3
Views
467
Fluff
Fluff

Forum statistics

Threads
1,223,911
Messages
6,175,323
Members
452,635
Latest member
laura12345

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