关于用VBA替代数组公式的问题

chxw68

1. Sub test()
   
2.     Dim r%, i%
   
3.     Dim arr, brr
   
4.     Dim d As Object
   
5.     Set d1 = CreateObject("scripting.dictionary")
   
6.     Set d2 = CreateObject("scripting.dictionary")
   
7.     With Worksheets("统计表")
   
8.         r = .Cells(.Rows.Count, 2).End(xlUp).Row
   
9.         .Range("h4:k" & r).ClearContents
   
10.         brr = .Range("a2:l" & r)
    
11.         For i = 3 To UBound(brr)
    
12.             xm = brr(i, 2) & "+" & brr(i, 3)
    
13.             d1(xm) = i
    
14.         Next
    
15.         For j = 8 To 11
    
16.             d2(brr(2, j)) = j
    
17.         Next
    
18.     End With
    
19.     With Worksheets("标准用量")
    
20.         r = .Cells(.Rows.Count, 2).End(xlUp).Row
    
21.         c = .Cells(2, .Columns.Count).End(xlToLeft).Column
    
22.         arr = .Range("a2").Resize(r - 1, c)
    
23.     End With
    
24.     For i = 2 To UBound(arr)
    
25.         xm = arr(i, 2) & "+" & arr(i, 3)
    
26.         If d1.exists(xm) Then
    
27.             m = d1(xm)
    
28.             For j = 8 To UBound(arr, 2)
    
29.                 If d2.exists(arr(1, j)) Then
    
30.                     n = d2(arr(1, j))
    
31.                     brr(m, n) = brr(m, n) + arr(i, j)
    
32.                 End If
    
33.                 yf = Month(arr(1, j))
    
34.                 If d2.exists(yf) Then
    
35.                     n = d2(yf)
    
36.                     brr(m, n) = brr(m, n) + arr(i, j)
    
37.                 End If
    
38.             Next
    
39.         End If
    
40.     Next
    
41.     With Worksheets("统计表")
    
42.         .Range("a2").Resize(UBound(brr), UBound(brr, 2)) = brr
    
43.     End With
    
44. End Sub
    

复制代码

chxw68

参与一下。

于箱长

小白兔3399 发表于 2023-4-27 22:40
太厉害了，非常感谢。

可否请老师再帮忙优化一下，就是我测试中发现，如果是统计表中的部门，在标准用 ...

再去掉一个字典，压缩一下

于箱长

chxw68 发表于 2023-4-28 10:04
参与一下。

褚老师太棒了 提前祝老师劳动节快乐