Question

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

我已经使代码可以工作，但是它的效率非常低，每30秒运行大约1000k条记录，这对于几十万条记录是不可行的。我尝试了几种不同的选项，大家都在不同的主题中发布了这些选项，但是肯定缺少某些内容。

你能看看吗？

我看过的大多数线程都引用了通过单个单元格或同一工作表进行的直接输入来执行查找。这是工作表A上的一列（ATB-Allowance Reserving-Calc），然后在工作表B上的表中查找查找（计划全局查找）。

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

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

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

我不是只尝试一两次的人，所以这绝对是我的尽头。

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单元格操作将通过使用数组最小化。添加上面用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

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

编辑：已修改以适应超过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

修改了最后一个答案以提高效率和提出新要求，处理大约12万行的测试时间仅为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

需要提高excel vba vlookup的效率

2 个答案: