需要让excel vba vlookup更高效

Question

我正在为我的组织重新设计一些财务报告，以摆脱第三方软件，并希望使用 VBA 来协助实现自动化。从大学开始就没有写过VBA，所以有点生疏。

我已经让代码工作了，但是它的效率非常低，并且每 30 秒运行大约 1000k 条记录，这对于几十万条记录是不可行的。我已经尝试了几种不同的选项，你们都在不同的线程中发布了这些选项，但一定是遗漏了一些东西。

你能看一下吗？

我看过的大多数线程都通过单个单元格或同一张表引用直接输入来执行查找。这是工作表 A 上的单个列（ATB-Allowance Reserving-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

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

提前感谢您的帮助。这是一个很好的资源，因为到目前为止，我已经能够在这个网站上解决 99% 的问题。

编辑

Ahmed 提供的这段代码运行良好，但我还需要一个标准：

如果附加列（“T”帐户基类）是“IP”，那么我们可以按照当前设置从“计划全局查找 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 单元格操作将通过使用数组来最小化。添加上面用数组修改的代码

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

使用我的列和范围猜测测试的代码。因为我个人不喜欢关闭计算、事件处理和屏幕更新（在正常情况下），所以我没有添加标准行。但是，您可以使用这些标准技术，具体取决于工作文件条件。

编辑：修改以适应阵列转置限制的 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