[已解决]数据汇总

misluo

求助！根据数据源自动汇总数据到结果表中，详见附件。
有劳各位。

最佳答案

月排行榜 / 总排行榜

grf1973

2016-4-8 14:51

1. Sub 汇总()
   
2.     arr = Sheets("数据源").[a1].CurrentRegion
   
3.     Set d = CreateObject("scripting.dictionary")
   
4.     ReDim brr(1 To UBound(arr), 1 To 5)
   
5.     For i = 2 To UBound(arr)
   
6.         x = arr(i, 2) & arr(i, 3)
   
7.         If Not d.exists(x) Then
   
8.             n = n + 1
   
9.             d(x) = n
   
10.             For j = 1 To 5
    
11.                 brr(n, j) = arr(i, j)
    
12.             Next
    
13.         End If
    
14.         y = x & arr(i, 6)
    
15.         d(y) = d(y) + arr(i, 7)
    
16.     Next
    
17.     With Sheet1
    
18.         .[b2].Resize(n, 5) = brr
    
19.         crr = .[a1].CurrentRegion
    
20.         For i = 2 To UBound(crr)
    
21.             x = crr(i, 3) & crr(i, 4)
    
22.             For j = 7 To UBound(crr, 2)
    
23.                 y = x & crr(1, j)
    
24.                 crr(i, j) = d(y)
    
25.             Next
    
26.         Next
    
27.         .[a1].CurrentRegion = crr
    
28.         .[b2].Resize(n, j).Sort key1:=.[f2], key2:=.[e2]     '按生产状态及日期排序
    
29.     End With
    
30. End Sub
    

复制代码

跳转到最佳答案楼层

grf1973

1. Sub 汇总()
   
2.     arr = Sheets("数据源").[a1].CurrentRegion
   
3.     Set d = CreateObject("scripting.dictionary")
   
4.     ReDim brr(1 To UBound(arr), 1 To 5)
   
5.     For i = 2 To UBound(arr)
   
6.         x = arr(i, 2) & arr(i, 3)
   
7.         If Not d.exists(x) Then
   
8.             n = n + 1
   
9.             d(x) = n
   
10.             For j = 1 To 5
    
11.                 brr(n, j) = arr(i, j)
    
12.             Next
    
13.         End If
    
14.         y = x & arr(i, 6)
    
15.         d(y) = d(y) + arr(i, 7)
    
16.     Next
    
17.     With Sheet1
    
18.         .[b2].Resize(n, 5) = brr
    
19.         crr = .[a1].CurrentRegion
    
20.         For i = 2 To UBound(crr)
    
21.             x = crr(i, 3) & crr(i, 4)
    
22.             For j = 7 To UBound(crr, 2)
    
23.                 y = x & crr(1, j)
    
24.                 crr(i, j) = d(y)
    
25.             Next
    
26.         Next
    
27.         .[a1].CurrentRegion = crr
    
28.         .[b2].Resize(n, j).Sort key1:=.[f2], key2:=.[e2]     '按生产状态及日期排序
    
29.     End With
    
30. End Sub
    

复制代码

misluo

谢谢回复。排序是按照拼音，如果这样排序了？补料
生产中
生产中
全制程
暂缓
暂缓

misluo

生产中（S)
全制程（Q)

dsmch

1. Sub Macro1()
   
2. Dim arr, brr, crr, w, d, d2, i%, j&
   
3. Set d = CreateObject("scripting.dictionary")
   
4. Set d2 = CreateObject("scripting.dictionary")
   
5. With Sheets("数据源")
   
6.     arr = .[a1].CurrentRegion
   
7.     .[a1].CurrentRegion.Sort .[d2]
   
8.     brr = .[a1].CurrentRegion
   
9.     .[a1].CurrentRegion = arr
   
10. End With
    
11. ReDim crr(1 To UBound(brr), 1 To 12)
    
12. w = Array("补料", "生产中", "暂缓")
    
13. For Each c In [g1:l1]
    
14.     d(c.Value) = c.Column
    
15. Next
    
16. For i = 0 To UBound(w)
    
17.     For j = 2 To UBound(brr)
    
18.         If w(i) = brr(j, 5) Then
    
19.             zf = brr(j, 1) & "," & brr(j, 2) & "," & brr(j, 3)
    
20.             n = d(brr(j, 6))
    
21.             If Not d2.exists(zf) Then
    
22.                 s = s + 1
    
23.                 d2(zf) = s
    
24.                 crr(s, 1) = s
    
25.                 crr(s, 2) = brr(j, 1)
    
26.                 crr(s, 3) = brr(j, 2)
    
27.                 crr(s, 4) = brr(j, 3)
    
28.                 crr(s, 5) = brr(j, 4)
    
29.                 crr(s, 6) = brr(j, 5)
    
30.                 crr(s, n) = brr(j, 7)
    
31.             Else
    
32.                 s2 = d2(zf)
    
33.                 crr(s2, n) = crr(s2, n) + brr(j, 7)
    
34.             End If
    
35.         End If
    
36.     Next
    
37. Next
    
38. Range("a2").Resize(s, UBound(crr, 2)) = crr
    
39. End Sub

复制代码

乐乐2006201506

好羡慕这些高手。

misluo

dsmch 发表于 2016-4-8 16:27

TO dsmch大神，
      如果数据源只有一行的时候，程式会报错，请您再看看。
     

misluo

misluo 发表于 2016-4-9 13:45
TO dsmch大神，
      如果数据源只有一行的时候，程式会报错，请您再看看。

改变数据源数据后，程序跑出来数据也有些问题。麻烦您再看下

misluo

misluo 发表于 2016-4-9 13:45
TO dsmch大神，
      如果数据源只有一行的时候，程式会报错，请您再看看。

附件有问题，重新发！