Vlookup Macro fine-tuning

[aaleem]

Hi,

i have the below macro in one of the file which has more than 100,000+ records.

this macro is taking approx. 10 minutes to run.

is there any way we can speed up the process?
Any suggestion will be much apprciated.

Sub VlookupLocation()

Dim authorWs As Worksheet, detailsWs As Worksheet
Dim authorsLastRow As Long, detailsLastRow As Long, x As Long
Dim dataRng As Range

Set authorWs = ThisWorkbook.Worksheets("Unmatched GRN Report")
Set detailsWs = ThisWorkbook.Worksheets("Loc_Status")

authorsLastRow = authorWs.Range("A" & Rows.Count).End(xlUp).Row
detailsLastRow = detailsWs.Range("A" & Rows.Count).End(xlUp).Row

Set dataRng = detailsWs.Range("A2:L" & detailsLastRow)



For x = 2 To authorsLastRow
    On Error Resume Next
    
    If authorWs.Range("AD" & x).Value = "" Then
    
    authorWs.Range("AD" & x).Value = Application.WorksheetFunction.VLookup( _
    authorWs.Range("G" & x).Value, dataRng, 2, False)
    
    authorWs.Range("AG" & x).Value = Application.WorksheetFunction.VLookup( _
    authorWs.Range("G" & x).Value, dataRng, 5, False)
    
    authorWs.Range("AI" & x).Value = Application.WorksheetFunction.VLookup( _
    authorWs.Range("G" & x).Value, dataRng, 7, False)
    
    authorWs.Range("AL" & x).Value = Application.WorksheetFunction.VLookup( _
    authorWs.Range("G" & x).Value, dataRng, 10, False)
    
    
    authorWs.Range("AM" & x).Value = Application.WorksheetFunction.VLookup( _
    authorWs.Range("G" & x).Value, dataRng, 11, False)
    
    authorWs.Range("AN" & x).Value = Application.WorksheetFunction.VLookup( _
    authorWs.Range("G" & x).Value, dataRng, 12, False)
    
    Else
    End If
    
Next x

End Sub

 

[aaleem]

when faced by this sort of problem you might want to look at dictionaries which can do exactly the same thing and are reliably very fast, see this thread, which reduced a macro that took 1 hour 20 min utes to 10 seconds:
How to reduce number of loops in VBA

Excellent.

thank you so much offthelip.

best regards
aleem

when faced by this sort of problem you might want to look at dictionaries which can do exactly the same thing and are reliably very fast, see this thread, which reduced a macro that took 1 hour 20 min utes to 10 seconds:
How to reduce number of loops in VBA

Dear offthelip,

i tried using your code for the same sheets, im getting the runtime error 13 on

Dic(Loc_Status(i, 2)) = i

Please see below the code, i tried to set the worksheets as well, but it is not working.

  Sub dictionary()
    Dim i           As Long
    Dim Dic         As Object
    Dim ws1         As Worksheet
    Dim ws2         As Worksheet
    
    Set ws2 = Sheets("Loc_Status")
    With ws2
        Set Dic = CreateObject("Scripting.dictionary")
        For i = 2 To UBound(Loc_Status)
            Dic(Loc_Status(i, 2)) = i
        Next i
        
    End With
    
    Set ws1 = Sheets(" Unmatched GRN Report")
    
    With ws1
        For j = 2 To UBound(Data)
            tt = Dic(Data(j, 4))        ' this pick up the matching index from the first array
            ' incomplete because you haven't said what you are doing
        Next j
        
    End With
End Sub

thanks
aleem

 

[offthelip]

sorry very little time to look at this, hopefully this will give you the idea, untested and undoubtedly some errors:

Sub VlookupLocation2()
 Dim i           As Long
 Dim Dic         As Object

Dim authorWs As Worksheet, detailsWs As Worksheet
Dim authorsLastRow As Long, detailsLastRow As Long, x As Long
Dim dataRng As Variant

Set authorWs = ThisWorkbook.Worksheets("Unmatched GRN Report")
Set detailsWs = ThisWorkbook.Worksheets("Loc_Status")

authorsLastRow = authorWs.Range("A" & Rows.Count).End(xlUp).Row
detailsLastRow = detailsWs.Range("A" & Rows.Count).End(xlUp).Row

dataRng = detailsWs.Range("A1:L" & detailsLastRow) ' load it from row 1 so index equal row number
' load the dictionary the index is column A and value is the row number
    
        Set Dic = CreateObject("Scripting.dictionary")
        For i = 2 To UBound(dataRng)
            Dic(dataRng(i, 1)) = i
        Next i
        

authorrng = authorWs.Range(Cells(1, 1), Cells(authorsLastRow, 40)) 'this loads all the data from authorws columns A to An into a variant array


For x = 2 To authorsLastRow
    
     tt = Dic(Data(x, 7))        ' this pick up the matching index from the first array with value in column G
            ' incomplete because you haven't said what you are doing
    On Error Resume Next
    
    If authorWs.Range("AD" & x).Value = "" Then
    
    authorWs.Range("G" & x).Value = dataRng(tt, 2)
    
    authorWs.Range("AG" & x).Value = dataRng(tt, 5)
    
    authorWs.Range("AI" & x).Value = dataRng(tt, 7)
    
    authorWs.Range("AL" & x).Value = dataRng(tt, 10)
    
    
    authorWs.Range("AM" & x).Value = dataRng(tt, 11)
    
    authorWs.Range("AN" & x).Value = dataRng(tt, 12)
    
    Else
    End If
    
Next x

End Sub

 

[offthelip]

One error

tt = Dic(Data(x, 7))

should be

tt = Dic(authorrng(x, 7))

 

[Alex Blakenburg]

This should be faster:-

Sub VlookupLocation()

Dim authorWs As Worksheet, detailsWs As Worksheet
Dim authorsLastRow As Long, detailsLastRow As Long, x As Long
Dim dataRng As Range
Dim i As Long

Set authorWs = ThisWorkbook.Worksheets("Unmatched GRN Report")
Set detailsWs = ThisWorkbook.Worksheets("Loc_Status")

authorsLastRow = authorWs.Range("A" & Rows.Count).End(xlUp).Row
detailsLastRow = detailsWs.Range("A" & Rows.Count).End(xlUp).Row

Set dataRng = detailsWs.Range("A2:L" & detailsLastRow)

Dim dataArr As Variant, authorsArr As Variant
Dim authorsRng As Range
Dim authorsLastCol As Long
Dim dataDict As Object
Dim dataArrRow As Long

dataArr = dataRng.Value
Set dataDict = CreateObject("Scripting.dictionary")

authorsLastCol = authorWs.Cells(1, Columns.Count).End(xlToLeft).Column
With authorWs
    Set authorsRng = .Range(.Cells(2, "A"), .Cells(authorsLastRow, authorsLastCol))
End With
authorsArr = authorsRng.Value

' Load details range into Dictionary
' If duplicate in column A only the first will get loaded - same as for vlookup
For i = 1 To UBound(dataArr, 1)
    If Not dataDict.exists(dataArr(i, 1)) Then
        dataDict(dataArr(i, 1)) = i
    End If
Next i

' Mapping
' Authors
' AD AG AI AL AM AN
' 30 33 35 38 39 40
' Details
' 2  5  7  10 11 12 (G = 7)

For x = 1 To UBound(authorsArr)
    On Error Resume Next
   
    If authorsArr(x, 30) = "" And dataDict.exists(authorsArr(x, 7)) Then
        dataArrRow = dataDict(authorsArr(x, 7))
        authorsArr(x, 30) = dataArr(dataArrRow, 2)      'AD
        authorsArr(x, 33) = dataArr(dataArrRow, 5)       'AG
        authorsArr(x, 35) = dataArr(dataArrRow, 7)       'AI
        authorsArr(x, 38) = dataArr(dataArrRow, 10)      'AL
        authorsArr(x, 39) = dataArr(dataArrRow, 11)      'AM
        authorsArr(x, 40) = dataArr(dataArrRow, 12)      'AN
   
    End If
   
Next x
   
    authorsRng.Resize(, 1).Offset(, 30 - 1).Value = Application.Index(authorsArr, 0, 30)
    authorsRng.Resize(, 1).Offset(, 33 - 1).Value = Application.Index(authorsArr, 0, 33)
    authorsRng.Resize(, 1).Offset(, 35 - 1).Value = Application.Index(authorsArr, 0, 35)
    authorsRng.Resize(, 1).Offset(, 38 - 1).Value = Application.Index(authorsArr, 0, 38)
    authorsRng.Resize(, 1).Offset(, 39 - 1).Value = Application.Index(authorsArr, 0, 39)
    authorsRng.Resize(, 1).Offset(, 40 - 1).Value = Application.Index(authorsArr, 0, 40)
   
End Sub

 

[aaleem]

Dear Alex,

thank you so much for your suggestions, it works perfectly, this works even if there is a Table and it took only 4 seconds to complete the task.

Much appreciate your thoughts and suggestion.

regards
aleem

 

[aaleem]

One error

tt = Dic(Data(x, 7))

should be

tt = Dic(authorrng(x, 7))

Dear

One error

tt = Dic(Data(x, 7))

should be

tt = Dic(authorrng(x, 7))

Dear offthelip,

Thank you so much for your code, When I run the code I m getting a Run-time error'1004'

kind regards
Aleem

 

[Alex Blakenburg]

Appreciate the feedback. Glad we could help.

 

[kevin9999]

I think @Alex Blakenburg has provided you with an excellent solution. I thought I'd look at this purely as a practice coding exercise. If you're interested in an alternative.

Option Explicit
Sub VlookUp_Speed()
    Application.ScreenUpdating = False
    Application.Calculation = xlManual
    
    Dim authorWs As Worksheet, detailsWs As Worksheet
    Set authorWs = Worksheets("Unmatched GRN Report")
    Set detailsWs = Worksheets("Loc_Status")
    
    Dim lr1 As Long, lr2 As Long
    lr1 = authorWs.Cells(Rows.Count, 1).End(3).Row
    lr2 = detailsWs.Cells(Rows.Count, 1).End(3).Row
    
    detailsWs.Range("A2:L" & lr2).Name = "myRange"
    
    Dim rng1 As Range
    With authorWs.Cells(1, 1).CurrentRegion
        .AutoFilter 30, "="
        Set rng1 = authorWs.Range("AD2:AN" & lr1).SpecialCells(12)
        Set rng1 = Intersect(rng1, Union(Columns(30), Columns(33), Columns(35), Columns(38), Columns(39), Columns(40)))
        rng1.Value = "=vlookup($G2,myrange,Column()-28,false)"
        .AutoFilter
    End With
    
    With authorWs.Range("AD2:AN" & lr1)
        .Value = .Value
    End With
    
    Application.ScreenUpdating = True
    Application.Calculation = xlAutomatic
End Sub

 

[aaleem]

I think @Alex Blakenburg has provided you with an excellent solution. I thought I'd look at this purely as a practice coding exercise. If you're interested in an alternative.

Option Explicit
Sub VlookUp_Speed()
    Application.ScreenUpdating = False
    Application.Calculation = xlManual
   
    Dim authorWs As Worksheet, detailsWs As Worksheet
    Set authorWs = Worksheets("Unmatched GRN Report")
    Set detailsWs = Worksheets("Loc_Status")
   
    Dim lr1 As Long, lr2 As Long
    lr1 = authorWs.Cells(Rows.Count, 1).End(3).Row
    lr2 = detailsWs.Cells(Rows.Count, 1).End(3).Row
   
    detailsWs.Range("A2:L" & lr2).Name = "myRange"
   
    Dim rng1 As Range
    With authorWs.Cells(1, 1).CurrentRegion
        .AutoFilter 30, "="
        Set rng1 = authorWs.Range("AD2:AN" & lr1).SpecialCells(12)
        Set rng1 = Intersect(rng1, Union(Columns(30), Columns(33), Columns(35), Columns(38), Columns(39), Columns(40)))
        rng1.Value = "=vlookup($G2,myrange,Column()-28,false)"
        .AutoFilter
    End With
   
    With authorWs.Range("AD2:AN" & lr1)
        .Value = .Value
    End With
   
    Application.ScreenUpdating = True
    Application.Calculation = xlAutomatic
End Sub

 

[aaleem]

Thank you very much kevin9999 for your time and thoughts.

Excellent piece of code. works faster. only two things.

i have tested this code as well,

if the authorWs already has the filter on the columns, we need to remove the filter or update the code

.AutoFilter

after


and in column 30 of authorWs doesn't have blanks then this will throughout the error.

kind regards
aleem