请大师帮忙把这个VBA加速

pkkgong

请大师帮忙把这个VBA加速

佛山小老鼠

1. Sub test()
   
2.     Dim Dic, arr1, arr2, arr3(1 To 10000, 1 To 1), k
   
3.     Set Dic = CreateObject("scripting.dictionary")
   
4.     arr1 = Sheets(1).Range("A1").CurrentRegion
   
5.     For x = 1 To UBound(arr1)
   
6.         Dic(arr1(x, 1)) = arr1(x, 2)
   
7.     Next x
   
8.     arr2 = Sheets(2).Range("A1").CurrentRegion
   
9.     For x = 1 To UBound(arr2)
   
10.         If Dic.exists(arr2(x, 1)) Then
    
11.             arr3(x, 1) = Dic(arr2(x, 1))
    
12.         Else
    
13.             arr3(x, 1) = ""
    
14.         End If
    
15.     Next x
    
16.     Sheets(2).Range("C1").CurrentRegion.Clear
    
17.     Sheets(2).[C1].Resize(UBound(arr2), 1) = arr3
    
18. End Sub

复制代码

lsc900707

对比测试代码运行时间：
Sub main()
tms = Timer
Set Dic = CreateObject("scripting.dictionary") '后期绑定字典
For i = 1 To 100 'Sheet1中有多少行，这里改为多少
Dic(Sheets(1).Cells(i, "A").Value) = Sheets(1).Cells(i, "B") 'Sheet1中名为字典目录，数值为字典项目
Next
For i = 1 To 200 'sheet2中最大行数
If Dic.exists(Cells(i, "A").Value) Then '如果字典中存在
Cells(i, "C") = Dic(Cells(i, "A").Value) '将字典中相应的值赋予C列中
End If
Next i
MsgBox Format(Timer - tms, "0.0000s")
End Sub
Sub test()
    tms = Timer
    Set d = CreateObject("scripting.dictionary")
    arr = Sheet1.[a1].CurrentRegion
    m = UBound(arr)
    For i = 1 To m
        d(arr(i, 1)) = arr(i, 2)
    Next
    brr = [a1].CurrentRegion
    For i = 1 To UBound(brr)
        If d.exists(brr(i, 1)) Then brr(i, 1) = d(arr(i, 1))
    Next
    [c1].Resize(m, 1) = brr
    MsgBox Format(Timer - tms, "0.0000s")
End Sub

lsc900707

附件回传，以供参考：

pkkgong

lsc900707 发表于 2017-10-6 07:20
对比测试代码运行时间：
Sub main()
tms = Timer

你好，请问
Sub test()
    tms = Timer
    Set d = CreateObject("scripting.dictionary")
    arr = Sheet1.[a1].CurrentRegion
    m = UBound(arr)
    For i = 1 To m
        d(arr(i, 1)) = arr(i, 2)
    Next
    brr = [a1].CurrentRegion
    For i = 1 To UBound(brr)
        If d.exists(brr(i, 1)) Then brr(i, 1) = d(arr(i, 1))
    Next
    [c1].Resize(m, 1) = brr
    MsgBox Format(Timer - tms, "0.0000s")
End Sub
这个想变多列引出应该怎么修改

lsc900707

pkkgong 发表于 2018-8-16 15:10
你好，请问
Sub test()
    tms = Timer

结合附件来说明问题吧。

pkkgong

lsc900707 发表于 2018-8-16 15:13
结合附件来说明问题吧。

想是表1中 的第2、3、4……列同时引出来，还请老师帮忙。

lsc900707

pkkgong 发表于 2018-8-16 15:28
想是表1中 的第2、3、4……列同时引出来，还请老师帮忙。

1. Sub test()
   
2.     tms = Timer
   
3.     Set d = CreateObject("scripting.dictionary")
   
4.     arr = Sheet1.[a1].CurrentRegion
   
5.     m = UBound(arr)
   
6.     For i = 1 To m
   
7.         d(arr(i, 1)) = Array(arr(i, 2), arr(i, 3), arr(i, 4), arr(i, 5))
   
8.     Next
   
9.     r = Cells(Rows.Count, 1).End(3).Row
   
10.     brr = Range("a1:f" & r)
    
11.     For i = 1 To UBound(brr)
    
12.         For j = 3 To 6
    
13.             If d.exists(brr(i, 1)) Then brr(i, j) = d(brr(i, 1))(j - 3)
    
14.         Next
    
15.     Next
    
16.     Range("a1:f" & r) = brr
    
17.     MsgBox Format(Timer - tms, "0.0000s")
    
18. End Sub

复制代码

lsc900707

pkkgong 发表于 2018-8-16 15:28
想是表1中 的第2、3、4……列同时引出来，还请老师帮忙。

附件供测试：

pkkgong

非常，感谢老师的帮忙