EXCEL宏:用字典代替Vlookup
2020-06-18 06:18  By  吕进   

Vlookup,在vba中一般用Application.Vlookup来实现,但总归要通过循环完成,如有不匹配的还报错,感觉效率不高。这里直接上几个用字典替代vlookup的方法。
方法一(经测试,3000行数据匹配,只需0.0156秒):

Sub VLOOKUP_01()
    Dim t As Date
    t = Timer
    Application.ScreenUpdating = False
    Sheets("DD").Range("AE2:AF10000").Clear
    Set ddcl = Sheets("数据源")
    Set dd = Sheets("目标表")
    
    Dim data, temp, arr, brr
    Dim d, v
    Dim i&, k&
    Set d = CreateObject("scripting.dictionary")
    Set v = CreateObject("scripting.dictionary")
    data = ddcl.[a2].CurrentRegion '被索引的数据表,也可以用具体的区域
    'data = ddcl.Range("A1:D65536")
    For i = 2 To UBound(data)
        d(data(i, 1) & "") = data(i, 3) '被取值所在列,如果只匹配一列,就不需v字典了
        v(data(i, 1) & "") = data(i, 4) '被取值所在列
    Next

    ddm = dd.Range("A65536").End(xlUp).Row
    temp = dd.Range("k1:k" & ddm) '索引参照列,注意必须是第一行开始
    ReDim arr(2 To UBound(temp), 1 To 1)
    ReDim brr(2 To UBound(temp), 1 To 1)
    For k = 2 To UBound(temp)
        arr(k, 1) = d(temp(k, 1))
        brr(k, 1) = v(temp(k, 1))
    Next
    dd.[AE2].Resize(UBound(arr) - 1, 1) = arr
    dd.[AF2].Resize(UBound(brr) - 1, 1) = brr
    Set d = Nothing    
    MsgBox "运行" & Format((Timer - t), "0.0000") & "秒"
End Sub
如需屏显代码,请尝试把手机横过来!
注意:目标表中的索引参照范围,必须从表的第一行开始,或者用dd.[K1].CurrentRegion
方式二(以下转自网络):
Sub VLOOKUP_02()
    Dim d, ar, br, cr, wb As Workbook
    Set d = CreateObject("Scripting.Dictionary")
    br = Worksheets("Sheet1").[A1].CurrentRegion  '需要配置的数据表
    ar = Worksheets("R").[A1].CurrentRegion  '目标表
    ReDim CRR(1 To UBound(br) - 1, 1 To 1) '配置表的循环列数
    For I = 2 To UBound(ar)      '从目标表需要关联的字段
        d(ar(I, 4)) = ar(I, 6)
    Next
    For I = 2 To UBound(br)
        CRR(I - 1, 1) = d(br(I, 4))  '将CRR写到BRR表中
    Next
    Worksheets("Sheet1").Range("EJ2").Resize(UBound(br), 1) = CRR '匹配
End Sub
如需屏显代码,请尝试把手机横过来!

方式三:
Sub VLOOKUP_03()
Dim arr, d As Object, CRR '
Set d = CreateObject("scripting.dictionary")    
arr = Worksheets("基础信息表").[a1].CurrentRegion  
brr = Worksheets("统计结果").[a1].CurrentRegion
For i = 2 To UBound(arr)
  d(arr(i, 1)) = arr(i, 6)
  Next

  ReDim CRR(2 To UBound(brr), 1 To 1)  '匹配目标表内容
  For J = 2 To UBound(brr)
  CRR(J, 1) = d(brr(J, 2))'''在字典里查找BRR值并返回相应值
  Next
  
   Worksheets("统计结果").[C2].Resize(UBound(CRR) - 1, 1) = CRR  
   Set d = Nothing
End Sub
如需屏显代码,请尝试把手机横过来!

方式四(多列匹配):
Sub VLOOKUP_04()
Dim arr, d As Object, CRR '数组brr用来存放求和数据    '创建字典
Set d = CreateObject("scripting.dictionary")    '数组赋值
arr = Worksheets("基础信息表").[a1].CurrentRegion    '重置数组brr大小
brr = Worksheets("统计结果").[a1].CurrentRegion

For i = 2 To UBound(arr)
d(arr(i, 1)) = arr(i, 6) & "," & arr(i, 7)
Next

ReDim CRR(2 To UBound(brr), 1 To 1)
ReDim DRR(2 To UBound(brr), 1 To 1)
For J = 2 To UBound(brr)
   If d(brr(J, 2)) <> "" Then
   CRR(J, 1) = Split(d(brr(J, 2)), ",")(0) '在BRR里查找到此名,并返回对应值
   DRR(J, 1) = Split(d(brr(J, 2)), ",")(1)
   Else
   CRR(J, 1) = ""
   DRR(J, 1) = ""
   End If
   Next  
   Worksheets("统计结果").[C2].Resize(UBound(CRR) - 1, 1) = CRR
   Worksheets("统计结果").[D2].Resize(UBound(CRR) - 1, 1) = DRR  
    Set d = Nothing
End Sub
如需屏显代码,请尝试把手机横过来!

阅读( 934 )    vba vlookup 字典 数组 宏 excel