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
欢迎分享,转载请注明来源:内存溢出
评论列表(0条)