Need to make excel vba vlookup more efficient - excel

Question

I'm redesigning some finance reports for my organization to move away from a 3rd party software and looking to use VBA to assist in the automation. Haven't written VBA since college, so a little rusty.
I've gotten the code to work, however it's very inefficient and is running at about 1000k records every 30 seconds, which is not feasible with a few hundred thousand records. I've tried several different options that you all have posted in different threads, but must be missing something.
Can you please take a look?
Most threads I've looked at have referenced either a direct input via single cell or same sheet to perform the lookup. This is a single column on Sheet A (ATB-Allowance Reserving-Calc) and then find lookups in table on Sheet B (Plan Global Lookups).
I do want it to skip over errors, and return nothing.
I've tried the fill down method and copy and paste, neither of which I can get to work with a formula. They just seem to want to fill with the value from the original formula.
I'm thinking it's not working due to jumping back and forth between sheets, which I've encountered issues with in different calculations.
I'm not one to just try one or two times, so this is definitely me at the end of my rope.
Dim GlobalExpPct As Variant
Range("AI2").Select 'Gets historical rates from Plan Global Lookups tab
Do
On Error Resume Next
GlobalExpPct = Application.WorksheetFunction.VLookup(ActiveCell.Offset(0, -24), Sheets("Plan Global Lookups").Range("A:B"), 2, False)
ActiveCell.value = GlobalExpPct
GlobalExpPct = vbNullString
ActiveCell.Offset(1, 0).Select
Loop While ActiveCell.Row < 1000 'have this in place to keep it from looping through all the records
I suspect the slow processing is due to selecting of the next cell each time, and then essentially calling the worksheet values and formula again. I'm typically seeing that the formula is returning either null value or getting the same value from the previous formula in the fill down.
Thanks for the help in advance. This is a great resource as I've been able to solve 99% of my issues so far on this site.
Edit
This code provided by Ahmed are working great, but I need one more criteria:
If an additional column ("T" Account Base Class) is "IP", then we can pull from the "Plan Global Lookups A:B" as currently setup. However, if it's populated otherwise, we'll need to pull from a lookup on another column. We can duplicate the table on the same sheet or still use column A as the lookup for the plan, whichever is the most efficient. Here is the code as it stands today which is working perfectly:
Sub GetGlobals()
Dim IntervalProcessing60k As Integer
Dim SRow As Long
Dim ERow As Long
Dim Src As Variant
Dim AcctPlan
Dim GlobalExpPct As Variant
Dim AcctPlanRng As Range
Dim Rslt() As Variant
Dim t As Date
Dim GetGlobalTime As Date
Dim ActWs As Worksheet
Dim ATBAllowResCalc As Worksheet
Set ActWs = ThisWorkbook.ActiveSheet
Set PlanGlobalWs = ThisWorkbook.Sheets("Plan Global Lookups")
Set ATBAllowResCalc = ThisWorkbook.Sheets("ATB-Allowance Reserving-Calc")
Set AcctGlobalRng = PlanGlobalWs.Range("A1:B" & PlanGlobalWs.Cells(PlanGlobalWs.Rows.Count, 1).End(xlUp).Row)
t = Now()
LastRow = Range("A" & Rows.Count).End(xlUp).Row
IntervalProcessing60k = 0
SRow = 2
ERow = LastRow
Src = ActWs.Range("K" & SRow & ":K" & ERow).value
X = 1
For Rw = SRow To ERow
AcctPlan = Src(Rw - SRow + 1, 1)
On Error Resume Next
GlobalExpPct = Application.WorksheetFunction.VLookup(AcctPlan, AcctGlobalRng, 2, False)
On Error GoTo 0
ReDim Preserve Rslt(1 To X)
Rslt(X) = IIf(IsNull(GlobalExpPct), "", GlobalExpPct)
GlobalExpPct = vbNullString
If Rw > 120000 Then Debug.Print Rw, X, Src(Rw - SRow + 1, 1), Rslt(X)
If X = 60000 Then
ActWs.Range("AI" & IntervalProcessing60k * 60000 + SRow).Resize(UBound(Rslt, 1), 1).value = Application.Transpose(Rslt)
IntervalProcessing60k = IntervalProcessing60k + 1
X = 1
ReDim Rslt(1 To 1)
Else
X = X + 1
End If
Next Rw
ActWs.Range("AI" & IntervalProcessing60k * 60000 + SRow).Resize(UBound(Rslt, 1), 1).value = Application.Transpose(Rslt)
GetGlobalTime = Format(Now() - t, "hh:mm:ss")
End Sub

Answer 1

May try this and see if performance improves
Sub testModified()
Dim GlobalExpPct As Variant, Rng As Range, Rw As Long
Dim ValtoLook, Ws As Worksheet, ActWs As Worksheet, tm As Double
tm = Timer
Set ActWs = ThisWorkbook.ActiveSheet
Set Ws = ThisWorkbook.Sheets("Plan Global Lookups")
'Set Rng = Ws.Range("A:B")
'this would be more efficent
Set Rng = Ws.Range("A1:B" & Ws.Cells(Ws.Rows.Count, 1).End(xlUp).Row)
For Rw = 2 To 1000
ValtoLook = ActWs.Range("AI" & Rw).Offset(0, -24).Value
On Error Resume Next
GlobalExpPct = Application.WorksheetFunction.VLookup(ValtoLook, Rng, 2, False)
On Error GoTo 0
Range("AI" & Rw).Value = GlobalExpPct
GlobalExpPct = vbNullString
Next Rw
Debug.Print " Time in second " & Timer - tm; ""
End Sub
if i have not correctly guessed the columns and ranges you are working with, may kindly modify them to your requirement.
It could be made efficient if you confirm there is all the values of Column K and AI are values and they are not inter dependent with some formulas etc. the above code may prove sufficient for 1000 rows. But for heavy files with 10-1000 K rows, the code required to be more efficient. in that case Excel cell operations are to be minimized by using array. Adding above code modified with Array
Sub testModifiedArray()
Dim GlobalExpPct As Variant, Rng As Range, Rw As Long
Dim ValtoLook, Ws As Worksheet, ActWs As Worksheet
Dim Rslt() As Variant, Src As Variant, tm As Double
tm = Timer
Set ActWs = ThisWorkbook.ActiveSheet
Set Ws = ThisWorkbook.Sheets("Plan Global Lookups")
'Set Rng = Ws.Range("A:B")
'next line would be more efficent, You may define range directly if you know the end row
Set Rng = Ws.Range("A1:B" & Ws.Cells(Ws.Rows.Count, 1).End(xlUp).Row)
Src = ActWs.Range("K2:K1000").Value
For Rw = 2 To 1000
ValtoLook = Src(Rw - 1, 1)
On Error Resume Next
GlobalExpPct = Application.WorksheetFunction.VLookup(ValtoLook, Rng, 2, False)
On Error GoTo 0
ReDim Preserve Rslt(1 To Rw - 1)
Rslt(Rw - 1) = IIf(IsNull(GlobalExpPct), "", GlobalExpPct)
'Debug.Print Rslt(Rw - 1)
GlobalExpPct = vbNullString
Next Rw
ActWs.Range("AI2").Resize(UBound(Rslt, 1), 1).Value = Application.Transpose(Rslt)
Debug.Print " Time in second " & Timer - tm; ""
End Sub
Both the code tested with my Guess of Column and ranges. As I personally don't prefer to keep calculations, event processing and screen updating off (in normal cases) i haven't added that standard lines. However you may use these standard techniques, depending on the working file condition.
Edit: modified to accommodate overcome 65K limit of array transpose limt
Option Explicit
Sub testModifiedArray2()
Dim GlobalExpPct As Variant, rng As Range, Rw As Long
Dim ValtoLook, Ws As Worksheet, ActWs As Worksheet
Dim Rslt() As Variant, Src As Variant, tm As Double
Dim Chunk60K As Integer, X As Long, SRow As Long, ERow As Long
tm = Timer
Set ActWs = ThisWorkbook.ActiveSheet
Set Ws = ThisWorkbook.Sheets("Plan Global Lookups")
'Set Rng = Ws.Range("A:B")
'next line would be more efficent, You may define range directly if you know the end row
Set rng = Ws.Range("A1:B" & Ws.Cells(Ws.Rows.Count, 1).End(xlUp).Row)
Chunk60K = 0
SRow = 2
ERow = 120030
Src = ActWs.Range("K" & SRow & ":K" & ERow).Value
X = 1
For Rw = SRow To ERow
ValtoLook = Src(Rw - SRow + 1, 1)
On Error Resume Next
GlobalExpPct = Application.WorksheetFunction.VLookup(ValtoLook, rng, 2, False)
On Error GoTo 0
ReDim Preserve Rslt(1 To X)
Rslt(X) = IIf(IsNull(GlobalExpPct), "", GlobalExpPct)
GlobalExpPct = vbNullString
If Rw > 120000 Then Debug.Print Rw, X, Src(Rw - SRow + 1, 1), Rslt(X)
If X = 60000 Then
ActWs.Range("AI" & Chunk60K * 60000 + SRow).Resize(UBound(Rslt, 1), 1).Value = Application.Transpose(Rslt)
Chunk60K = Chunk60K + 1
X = 1
ReDim Rslt(1 To 1)
Else
X = X + 1
End If
Next Rw
ActWs.Range("AI" & Chunk60K * 60000 + SRow).Resize(UBound(Rslt, 1), 1).Value = Application.Transpose(Rslt)
Debug.Print " Time in second " & Timer - tm; ""
End Sub

Answer 2

Last Answer modified for improved efficiency and new requirement, Test time to process around 120 K rows is around 6 seconds only. additionally column "T" is tested for a value "IP" and lookup value pulled up from column B or C accordingly.
Option Explicit
Sub GetGlobals()
Dim SRow As Long
Dim ERow As Long
Dim Src As Variant, Src2 As Variant
Dim AcctPlan
Dim GlobalExpPct As Variant
Dim AcctPlanRng As Range
Dim Rslt() As Variant
Dim tm As Double
Dim ActWs As Worksheet, PlanGlobalWs As Worksheet
Dim AcctGlobalRng As Range
Dim ATBAllowResCalc As Worksheet
Dim LastRow As Long, X As Long, Rw As Long
Dim LookArr As Variant, LookUpCol As Integer
Set ActWs = ThisWorkbook.ActiveSheet
Set PlanGlobalWs = ThisWorkbook.Sheets("Plan Global Lookups")
'Set ATBAllowResCalc = ThisWorkbook.Sheets("ATB-Allowance Reserving-Calc")
Set AcctGlobalRng = PlanGlobalWs.Range("A1:C" & PlanGlobalWs.Cells(PlanGlobalWs.Rows.Count, 1).End(xlUp).Row)
LookArr = AcctGlobalRng.Value
tm = Timer
LastRow = Range("K" & Rows.Count).End(xlUp).Row
SRow = 2
ERow = LastRow
Src = ActWs.Range("K" & SRow & ":K" & ERow).Value
Src2 = ActWs.Range("T" & SRow & ":T" & ERow).Value
ReDim Rslt(1 To ERow - SRow + 1, 1 To 1)
For Rw = SRow To ERow
AcctPlan = Src(Rw - SRow + 1, 1)
GlobalExpPct = ""
For X = 1 To UBound(LookArr, 1)
If AcctPlan = LookArr(X, 1) Then
LookUpCol = IIf(Src2(Rw - SRow + 1, 1) = "IP", 2, 3)
GlobalExpPct = LookArr(X, LookUpCol)
Exit For
End If
Next X
GlobalExpPct = IIf(IsNull(GlobalExpPct), "", GlobalExpPct)
Rslt(Rw - SRow + 1, 1) = GlobalExpPct
Next Rw
ActWs.Range("AI" & SRow).Resize(UBound(Rslt, 1), 1).Value = Rslt
Debug.Print " Time in second " & Timer - tm; ""
End Sub