[已解决]修改代码

雄鹰2013

以下文件中的代码运行速度不够理想，那位大师能修改下代码谢谢

最佳答案

月排行榜 / 总排行榜

大灰狼1976

2014-6-7 16:22

结果输出在K列

1. Sub bbb()
   
2. t = Timer
   
3. Dim arr, arr1, i&, d As Object, d1 As Object, da As Date
   
4. da = Sheets(4).[a2]
   
5. Set d = CreateObject("scripting.dictionary")
   
6. Set d1 = CreateObject("scripting.dictionary")
   
7. arr = Sheets(4).Range("a4:b" & Sheets(4).[a65536].End(3).Row)
   
8. ReDim arr1(1 To UBound(arr), 1 To 1)
   
9. For i = 1 To UBound(arr)
   
10.   d(arr(i, 1)) = Val(arr(i, 2))
    
11.   d1(arr(i, 1)) = i
    
12. Next i
    
13. arr = Sheets(2).[a1].CurrentRegion
    
14. For i = UBound(arr) To 2 Step -1
    
15.   If arr(i, 2) <= da And arr(i, 2) >= da - d(arr(i, 1)) Then arr1(d1(arr(i, 1)), 1) = arr1(d1(arr(i, 1)), 1) + arr(i, 3)
    
16. Next i
    
17. Sheets(4).[k4].Resize(UBound(arr1)) = arr1
    
18. MsgBox Timer - t
    
19. End Sub

复制代码

跳转到最佳答案楼层

大灰狼1976

结果输出在K列

1. Sub bbb()
   
2. t = Timer
   
3. Dim arr, arr1, i&, d As Object, d1 As Object, da As Date
   
4. da = Sheets(4).[a2]
   
5. Set d = CreateObject("scripting.dictionary")
   
6. Set d1 = CreateObject("scripting.dictionary")
   
7. arr = Sheets(4).Range("a4:b" & Sheets(4).[a65536].End(3).Row)
   
8. ReDim arr1(1 To UBound(arr), 1 To 1)
   
9. For i = 1 To UBound(arr)
   
10.   d(arr(i, 1)) = Val(arr(i, 2))
    
11.   d1(arr(i, 1)) = i
    
12. Next i
    
13. arr = Sheets(2).[a1].CurrentRegion
    
14. For i = UBound(arr) To 2 Step -1
    
15.   If arr(i, 2) <= da And arr(i, 2) >= da - d(arr(i, 1)) Then arr1(d1(arr(i, 1)), 1) = arr1(d1(arr(i, 1)), 1) + arr(i, 3)
    
16. Next i
    
17. Sheets(4).[k4].Resize(UBound(arr1)) = arr1
    
18. MsgBox Timer - t
    
19. End Sub

复制代码

su45

大灰狼用的是字典，咱用的是数组：

应收款统计.zip (28.39 KB, 下载次数: 4)

2014-6-7 16:40 上传

点击文件名下载附件