需要使Excel VBA Vlookup更加高效

Question

我正在重新设计一些财务报告，让我的组织脱离第三方软件，并希望使用VBA来协助自动化。自大学以来还没有写过VBA，所以有点生锈。

我已经可以使用代码，但是它效率很低，并且每30秒钟以大约1000k的记录运行，这对于数十万个记录不可行。我尝试了几个大家都在不同线程中发布的不同选项，但必须缺少某些内容。

你能看看吗？

我查看的大多数线程都引用了通过单个单元格或同一张纸进行查找的直接输入。这是A片A上的一列(ATB允许保留-CALC(，然后在表B上的表中找到查找(计划全局查找(。

我确实希望它跳过错误，然后什么也没返回。

我已经尝试了填充方法并复制和粘贴，我都无法使用公式。他们似乎只是想填充原始公式的值。

我认为由于床单之间的来回跳动而无法工作，这在不同的计算中遇到了问题。

我不是一个尝试一两次的人，所以这绝对是我的绳子。

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

我怀疑处理缓慢是由于每次选择下一个单元格，然后基本上调用工作表值和公式。我通常会看到该公式正在返回null值或从填充填充中的上一个公式中获得相同的值。

感谢提前的帮助。这是一个很好的资源，因为我能够在此网站上解决99％的问题。

edit

艾哈迈德(Ahmed(提供的此代码运行良好，但我需要一个标准：

如果附加的列(" T"帐户基类(是" IP"，则我们可以从当前设置的" Plan Global Lookups a：b"中拉出。但是，如果另有填充，我们需要从查找另一列中拉出。我们可以在同一张纸上复制表，或者仍然使用列A作为计划的查找，以最有效的效率。这是今天的代码，它正常工作：

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

可以尝试一下，看看性能是否改善

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

如果我没有正确猜到您正在使用的列和范围，则可能会根据您的要求将其修改为友善。

，如果您确认列k和ai是值的所有值，并且它们与某些公式相互依赖。上面的代码可能足以容纳1000行，则可以有效。但是对于具有10-1000 K行的重型文件，代码必须更有效。在这种情况下，应使用阵列将Excel Cell操作最小化。添加上面用数组修改的代码

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

两种代码都用我猜测列和范围进行了测试。由于我个人不希望保留计算，事件处理和屏幕更新(在正常情况下(，因此我没有添加标准行。但是，根据工作文件条件，您可以使用这些标准技术。

编辑：修改以适应克服阵列转置limt的65K限制

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

修改了提高效率和新需求的最后一个答案，测试时间约为120 k行约为6秒。此外，还测试了" t"列的值" ip"，并相应地从b或c上提取查找值。

。

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