sumproduct函数计算慢，能否用VBA解决？

momo445566

表中用了sumproduct进行多条件求和，因数据量大，计算太慢了，请高手前辈们帮忙解决，万分感谢！

wdx223

1. Sub HuiZong()
   
2. Dim data, i&, arr(), dicw, dich, k&, w&
   
3. 
   
4. data = Worksheets("数据源").UsedRange
   
5. ReDim arr(1 To UBound(data), 1 To 100)
   
6. Set dicw = CreateObject("Scripting.Dictionary")
   
7. Set dich = CreateObject("Scripting.Dictionary")
   
8. For i = 4 To UBound(data)
   
9.     If data(i, 2) <> "" Then
   
10.         If Not dich.exists(data(i, 2) & "|" & data(i, 10) & "|" & data(i, 11) & "|" & data(i, 14) & "|" & data(i, 15)) Then
    
11.             k = k + 1
    
12.             dich(data(i, 2) & "|" & data(i, 10) & "|" & data(i, 11) & "|" & data(i, 14) & "|" & data(i, 15)) = k
    
13.         End If
    
14.         If Not dicw.exists(data(i, 8) & "") Then
    
15.             w = w + 1
    
16.             dicw(data(i, 8) & "") = w
    
17.         End If
    
18.         arr(dich(data(i, 2) & "|" & data(i, 10) & "|" & data(i, 11) & "|" & data(i, 14) & "|" & data(i, 15)), dicw(data(i, 8) & "")) = _
    
19.         arr(dich(data(i, 2) & "|" & data(i, 10) & "|" & data(i, 11) & "|" & data(i, 14) & "|" & data(i, 15)), dicw(data(i, 8) & "")) + data(i, 20)
    
20.     End If
    
21. Next i
    
22. Application.DisplayAlerts = False
    
23. With Worksheets("汇总")
    
24.     .[G2].Resize(1, w) = dicw.keys
    
25.     .[G3].Resize(k, w) = arr
    
26.     With .Sort
    
27.         .SortFields.Clear
    
28.         .SortFields.Add Key:=Worksheets("汇总").[G2].Resize(1, w)
    
29.         .SetRange Worksheets("汇总").[G2].Resize(k + 1, w)
    
30.         .Orientation = xlLeftToRight
    
31.         .SortMethod = xlPinYin
    
32.         .Apply
    
33.     End With
    
34.     .[A3].Resize(k, 1).FormulaR1C1 = "=row(R[-2]C)"
    
35.     .[B3].Resize(k, 1) = Application.Transpose(dich.keys)
    
36.     .[B3].Resize(k, 1).TextToColumns other:=True, otherchar:="|"
    
37. End With
    
38. Application.DisplayAlerts = True
    
39. End Sub

复制代码

需要修改“数据源”表中T列公式，最后一个参数由“”改为0

momo445566

wdx223 发表于 2017-5-29 09:57
需要修改“数据源”表中T列公式，最后一个参数由“”改为0

十分感谢！我试了一下，可以了。

momo445566

感谢2楼，多条件求和已经实现了。
1、我想能否实现排序？首先是车间，然后是物料编号，最后是色号。
2、按周有欠数的就显示，没有欠数的周不显示？

wdx223

1. Sub HuiZong()
   
2. Dim data, i&, arr(), dicw, dich, k&, w&
   
3. 
   
4. data = Worksheets("数据源").UsedRange
   
5. ReDim arr(1 To UBound(data), 1 To 100)
   
6. Set dicw = CreateObject("Scripting.Dictionary")
   
7. Set dich = CreateObject("Scripting.Dictionary")
   
8. For i = 4 To UBound(data)
   
9.     If data(i, 2) <> "" And Round(data(i, 20), 2) <> 0 Then
   
10.         If Not dich.exists(data(i, 2) & "|" & data(i, 10) & "|" & data(i, 11) & "|" & data(i, 14) & "|" & data(i, 15)) Then
    
11.             k = k + 1
    
12.             dich(data(i, 2) & "|" & data(i, 10) & "|" & data(i, 11) & "|" & data(i, 14) & "|" & data(i, 15)) = k
    
13.         End If
    
14.         
    
15.         If Not dicw.exists(data(i, 8) & "") Then
    
16.             w = w + 1
    
17.             dicw(data(i, 8) & "") = w
    
18.         End If
    
19.         arr(dich(data(i, 2) & "|" & data(i, 10) & "|" & data(i, 11) & "|" & data(i, 14) & "|" & data(i, 15)), dicw(data(i, 8) & "")) = _
    
20.         arr(dich(data(i, 2) & "|" & data(i, 10) & "|" & data(i, 11) & "|" & data(i, 14) & "|" & data(i, 15)), dicw(data(i, 8) & "")) + data(i, 20)
    
21.     End If
    
22. Next i
    
23. Application.DisplayAlerts = False
    
24. With Worksheets("汇总")
    
25.     .[G2].Resize(1, w) = dicw.keys
    
26.     .[G3].Resize(k, w) = arr
    
27.     .[A3].Resize(k, 1).FormulaR1C1 = "=row(R[-2]C)"
    
28.     .[B3].Resize(k, 1) = Application.Transpose(dich.keys)
    
29.     .[B3].Resize(k, 1).TextToColumns other:=True, otherchar:="|"
    
30.     With .Sort
    
31.         .SortFields.Clear
    
32.         .SortFields.Add Key:=Worksheets("汇总").[G2].Resize(1, w)
    
33.         .SetRange Worksheets("汇总").[G2].Resize(k + 1, w)
    
34.         .Orientation = xlLeftToRight
    
35.         .SortMethod = xlPinYin
    
36.         .Apply
    
37.         .SortFields.Clear
    
38.         .SortFields.Add Key:=Worksheets("汇总").[B2].Resize(k + 1, 1)
    
39.         .SortFields.Add Key:=Worksheets("汇总").[C2].Resize(k + 1, 1)
    
40.         .SortFields.Add Key:=Worksheets("汇总").[F2].Resize(k + 1, 1)
    
41.         .SetRange Worksheets("汇总").[B2].Resize(k + 1, w + 5)
    
42.         .Header = xlYes
    
43.         .Orientation = xlTopToBottom
    
44.         .SortMethod = xlPinYin
    
45.         .Apply
    
46.     End With
    
47. End With
    
48. Application.DisplayAlerts = True
    
49. End Sub

复制代码

momo445566

wdx223 发表于 2017-5-29 15:28

谢谢前辈！解决我的大问题

nbcpa

wdx223 发表于 2017-5-29 15:28

请教一下前辈，运行时错误13，类型不匹配，那里的错，谢谢

wdx223

是因为最下面有空白数据行导致的
更改了取数区域

1. Sub HuiZong()
   
2. Dim data, i%, arr(), dicw, dich, k%, w%
   
3. 
   
4. With Worksheets("数据源")
   
5.     data = .Range("B1:B" & .Range("B" & .Rows.Count).End(xlUp).Row).EntireRow
   
6. End With
   
7. ReDim arr(1 To UBound(data), 1 To 100)
   
8. Set dicw = CreateObject("Scripting.Dictionary")
   
9. Set dich = CreateObject("Scripting.Dictionary")
   
10. 
    
11. For i = 4 To UBound(data)
    
12. 
    
13. If data(i, 2) <> "" And Round(data(i, 20), 2) <> 0 Then
    
14.         If Not dich.exists(data(i, 2) & "|" & data(i, 10) & "|" & data(i, 11) & "|" & data(i, 14) & "|" & data(i, 15)) Then
    
15.             k = k + 1
    
16.             dich(data(i, 2) & "|" & data(i, 10) & "|" & data(i, 11) & "|" & data(i, 14) & "|" & data(i, 15)) = k
    
17.         End If
    
18.         
    
19.         If Not dicw.exists(data(i, 8) & "") Then
    
20.             w = w + 1
    
21.             dicw(data(i, 8) & "") = w
    
22.         End If
    
23.         arr(dich(data(i, 2) & "|" & data(i, 10) & "|" & data(i, 11) & "|" & data(i, 14) & "|" & data(i, 15)), dicw(data(i, 8) & "")) = _
    
24.         arr(dich(data(i, 2) & "|" & data(i, 10) & "|" & data(i, 11) & "|" & data(i, 14) & "|" & data(i, 15)), dicw(data(i, 8) & "")) + data(i, 20)
    
25.     End If
    
26. Next i
    
27. Application.DisplayAlerts = False
    
28. With Worksheets("汇总")
    
29.     .[G2].Resize(1, w) = dicw.keys
    
30.     .[G3].Resize(k, w) = arr
    
31.     .[A3].Resize(k, 1).FormulaR1C1 = "=row(R[-2]C)"
    
32.     .[B3].Resize(k, 1) = Application.Transpose(dich.keys)
    
33.     .[B3].Resize(k, 1).TextToColumns other:=True, otherchar:="|"
    
34.     With .Sort
    
35.         .SortFields.Clear
    
36.         .SortFields.Add Key:=Worksheets("汇总").[G2].Resize(1, w)
    
37.         .SetRange Worksheets("汇总").[G2].Resize(k + 1, w)
    
38.         .Orientation = xlLeftToRight
    
39.         .SortMethod = xlPinYin
    
40.         .Apply
    
41.         .SortFields.Clear
    
42.         .SortFields.Add Key:=Worksheets("汇总").[B2].Resize(k + 1, 1)
    
43.         .SortFields.Add Key:=Worksheets("汇总").[C2].Resize(k + 1, 1)
    
44.         .SortFields.Add Key:=Worksheets("汇总").[F2].Resize(k + 1, 1)
    
45.         .SetRange Worksheets("汇总").[B2].Resize(k + 1, w + 5)
    
46.         .Header = xlYes
    
47.         .Orientation = xlTopToBottom
    
48.         .SortMethod = xlPinYin
    
49.         .Apply
    
50.     End With
    
51. End With
    
52. Application.DisplayAlerts = True
    
53. End Sub

复制代码

momo445566

感谢大家的帮助，谢谢！

nbcpa

wdx223 发表于 2017-5-31 09:10
是因为最下面有空白数据行导致的
更改了取数区域

谢谢wdx223，不过还是内存溢出，错误7