Fatal编程技术网
  • excel/
  • 需要使excel vba vlookup更高效

需要使excel vba vlookup更高效

excel vba

需要使excel vba vlookup更高效,excel,vba,vlookup,Excel,Vba,Vlookup,我正在为我的组织重新设计一些财务报告，以摆脱第三方软件，并希望使用VBA帮助实现自动化。从大学开始就没有写过VBA，所以有点生疏了 我已经让代码正常工作了，但是它非常低效，每30秒运行大约1000k条记录，这对于几十万条记录来说是不可行的。我尝试了几个不同的选项，你们都在不同的线程中发布了这些选项，但肯定遗漏了什么 你能看一下吗 我看过的大多数线程都引用了通过单个单元格或同一工作表直接输入的内容来执行查找。这是表a上的一列（ATB余量保留计算），然后在表B（计划全局查找）中查找 我确实希望它跳过

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

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

你能看一下吗

我看过的大多数线程都引用了通过单个单元格或同一工作表直接输入的内容来执行查找。这是表a上的一列（ATB余量保留计算），然后在表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
您可以尝试一下，看看性能是否有所提高

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-1000k行的重文件，代码需要更高效。在这种情况下，将使用数组最小化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
您可以尝试一下，看看性能是否有所提高

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-1000k行的重文件，代码需要更高效。在这种情况下，将使用数组最小化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
为了提高效率和满足新的要求，对上一个答案进行了修改，处理大约120K行的测试时间仅为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
为了提高效率和满足新的要求，对上一个答案进行了修改，处理大约120K行的测试时间仅为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
我自己也有点生疏，但我会尝试（1）使用显式单元格引用，比如cell（I，j）而不是Activecell。（2） 设置一个单元格，将其复制并粘贴到包含所有需要包含公式的单元格的范围内。您好，欢迎使用StackOverflow aka。“所以”请参阅“帮助”部分，因为这将指导您从我们社区获得更多支持。祝你一切顺利！干杯你可以做一些事情来帮助解决这个问题。我认为使用Excel的Power Query会得到最好的结果。将数据加载到表中，将其添加到Power Query，然后将两个表合并在一起。查找如何查找范围的最后一行。然后在
中查找
下一步
循环。。。同时，您的vlookup&select无疑是及时解决的问题。。。您可以尝试
查找
，学习如何删除
。选择
@Jay Nelson，感谢联系。我等待反馈和/或接受答案（至少保持精神），同时将时间进一步缩短到8-9秒，持续120 K。现在关于最新编辑中的目标，我搞不清楚，如果列B中的查找值为空，那么我们需要从列T（或IP）中提取该值，还是仅仅从列T（或IP）中提取该值。请澄清。找到解决办法将是一件愉快的事（如果我理解的话，这可能很容易）。等待反馈。快乐的计算。我自己也有点生疏，但我会尝试（1）使用显式的单元格引用，比如cell（I，j）而不是Activecell。（2） 设置一个单元格，将其复制并粘贴到包含所有需要包含公式的单元格的范围内。您好，欢迎使用StackOverflow aka。“所以”请参阅“帮助”部分，因为这将指导您从我们社区获得更多支持。祝你一切顺利！干杯你可以做一些事情来帮助解决这个问题。我认为使用Excel的Power Query会得到最好的结果。将数据加载到表中，将其添加到Power Query，然后将两个表合并在一起。查找如何查找范围的最后一行。然后在
中查找
下一步
循环。。。同时，您的vlookup&select无疑是及时解决的问题。。。你可以试试