VBA- 用字典工具匹配(类似Vlookup匹配)

VBA- 用字典工具匹配(类似Vlookup匹配),第1张

Sub 字典匹配1() '同一个工作簿里面用字典工具匹配

Application.ScreenUpdating = False '关闭屏幕更新,看不到宏的执行过程,但提高宏运行速度

Application.EnableEvents = False '关闭事件,防止触发事情,提高运行速度

Windows("匹配.xlsm").Activate

'Worksheets("匹配").Select

'Worksheets("数据源").Select

t = Timer

Dim i&, Myr&, arr, j&

Dim d1, d2, d3, d4, d5, d6, d7, k, m&, Arr1

Set d1 = CreateObject("Scripting.Dictionary") '定义字典'

Set d2 = CreateObject("Scripting.Dictionary") '定义字典'

Set d3 = CreateObject("Scripting.Dictionary") '定义字典'

Set d4 = CreateObject("Scripting.Dictionary") '定义字典'

Set d5 = CreateObject("Scripting.Dictionary") '定义字典'

Set d6 = CreateObject("Scripting.Dictionary") '定义字典'

Set d7 = CreateObject("Scripting.Dictionary") '定义字典'

'y = d(Arr(Range("c1:c200"))) + 1

Sheets("数据源").Select '开始运行字典'

With Sheets("数据源")

X = Range("a1").CurrentRegion.Rows.Count '设置最大行'

For i = 2 To X

d1(.Cells(i, 1).Value) = .Cells(i, 5).Value

d2(.Cells(i, 1).Value) = .Cells(i, 8).Value

d3(.Cells(i, 1).Value) = .Cells(i, 9).Value

d4(.Cells(i, 1).Value) = .Cells(i, 10).Value

d5(.Cells(i, 1).Value) = .Cells(i, 11).Value

d6(.Cells(i, 1).Value) = .Cells(i, 12).Value

d7(.Cells(i, 1).Value) = .Cells(i, 13).Value

Next i

End With

Sheets("匹配").Select

With Sheets("匹配")

y = Range("a1").CurrentRegion.Rows.Count '设置最大行'

For Z = 2 To y

.Cells(Z, 28).Value = d1(.Cells(Z, 1).Value)

.Cells(Z, 29).Value = d2(.Cells(Z, 1).Value)

.Cells(Z, 30).Value = d3(.Cells(Z, 1).Value)

.Cells(Z, 31).Value = d4(.Cells(Z, 1).Value)

.Cells(Z, 32).Value = d5(.Cells(Z, 1).Value)

.Cells(Z, 33).Value = d6(.Cells(Z, 1).Value)

.Cells(Z, 34).Value = d7(.Cells(Z, 1).Value)

Next Z

End With

End Sub

Sub 字典匹配2() '不同一个工作簿里面用字典工具匹配

Application.ScreenUpdating = False '关闭屏幕更新,看不到宏的执行过程,但提高宏运行速度

Application.EnableEvents = False '关闭事件,防止触发事情,提高运行速度

'y = d(Arr(Range("c1:c200"))) + 1

Sheets("数据源").Select '开始运行字典'

With Sheets("数据源")

X = Range("a1").CurrentRegion.Rows.Count '设置最大行'

For i = 2 To X

d1(.Cells(i, 1).Value) = .Cells(i, 5).Value

d2(.Cells(i, 1).Value) = .Cells(i, 8).Value

d3(.Cells(i, 1).Value) = .Cells(i, 9).Value

d4(.Cells(i, 1).Value) = .Cells(i, 10).Value

d5(.Cells(i, 1).Value) = .Cells(i, 11).Value

d6(.Cells(i, 1).Value) = .Cells(i, 12).Value

d7(.Cells(i, 1).Value) = .Cells(i, 13).Value

Next i

End With

Windows("匹配.xlsm").Activate '匹配目标

Worksheets("匹配").Select

With Sheets("匹配")

y = Range("a1").CurrentRegion.Rows.Count '设置最大行'

For Z = 2 To y

.Cells(Z, 28).Value = d1(.Cells(Z, 1).Value)

.Cells(Z, 29).Value = d2(.Cells(Z, 1).Value)

.Cells(Z, 30).Value = d3(.Cells(Z, 1).Value)

.Cells(Z, 31).Value = d4(.Cells(Z, 1).Value)

.Cells(Z, 32).Value = d5(.Cells(Z, 1).Value)

.Cells(Z, 33).Value = d6(.Cells(Z, 1).Value)

.Cells(Z, 34).Value = d7(.Cells(Z, 1).Value)

Next Z

End With

End Sub

A列是不是长数字(手机号、yhk号、身份z号这些),是的话试试看下面的代码,只修改了两行:

Sub test()

    Dim arr, brr, d, i

    Dim t

    t = Timer

    Set d = CreateObject("scripting.dictionary")

    arr = Sheet1.Range("a2:b145333")

    '''''''''''''''''''''''''''''''建立字典''''''''''''''''''''''''''''''''''''''''

    For i = 1 To UBound(arr)

        d(Trim(arr(i, 1))) = arr(i, 2) '通过循环,把要进行查询的源表中的关键字成为字典中的关键字以及关键字所对应的项

    Next

    '''''''''''''''字典建立完毕''''''''''''''''''''''''''''''''

    

    brr = Sheet1.Range("c2:d" & Cells(Rows.Count, 3).End(xlUp).Row)

    For i = 1 To UBound(brr)

        brr(i, 2) = d(Trim(brr(i, 1))) '用这个d(brr(i, 1)) ,取得brr(i,1)里的关键字,在前面所建立的字典中所对应的项。赋值给数组brr的第二列。

    Next

    ''''''''''''''写出数组''''''''''''''''''''''''''''''''''''''''''''''

    Sheet1.Range("c2").Resize(UBound(brr), UBound(brr, 2)) = brr

    Set d = Nothing

    MsgBox "程序运行时间为" & Timer - t

End Sub


欢迎分享,转载请注明来源:内存溢出

原文地址: http://outofmemory.cn/sjk/6841989.html

(0)
打赏 微信扫一扫 微信扫一扫 支付宝扫一扫 支付宝扫一扫
上一篇 2023-03-29
下一篇 2023-03-29

发表评论

登录后才能评论

评论列表(0条)

保存