有关汇总事项！

djy888

请教.rar (5.28 KB, 下载次数: 11)

2014-4-25 07:54 上传

点击文件名下载附件

请那位老师帮我看看！谢谢

ydlpc

用sumproduct函数
http://baike.baidu.com/link?url= ... y_iHLuEZzURPj7oGtQa

djy888

ydlpc 发表于 2014-4-25 08:11
用sumproduct函数
http://baike.baidu.com/link?url=gh6Dbub5IeqyLMlf-pJ4gbiAyGus8WlKuBYN9zf0Kf6x9aZmMp ...

数字太多用函数太慢无法用！谢谢！

蓝桥玄霜

1. Sub lqxs()
   
2. Dim Arr, i&, j&, aa, x$, y$
   
3. Dim d, k, t, d1, k1, t1
   
4. Application.DisplayAlerts = False
   
5. Set d = CreateObject("Scripting.Dictionary")
   
6. Set d1 = CreateObject("Scripting.Dictionary")
   
7. Sheet1.Activate
   
8. Arr = [a1].CurrentRegion
   
9. For i = 3 To UBound(Arr)
   
10.     x = Arr(i, 9) & "," & Arr(i, 14)
    
11.     d(x) = d(x) & i & ","
    
12.     y = Arr(i, 10) & "," & Arr(i, 14)
    
13.     d1(y) = d1(y) & i & ","
    
14. Next
    
15. k = d.keys: t = d.items
    
16. With Sheet2
    
17. .[a3:g5000].ClearContents
    
18. .[a3].Resize(d.Count) = Application.Transpose(k)
    
19. .[a3].Resize(d.Count).TextToColumns DataType:=xlDelimited, Comma:=True
    
20. For i = 0 To UBound(k)
    
21.     t(i) = Left(t(i), Len(t(i)) - 1)
    
22.     If InStr(t(i), ",") Then
    
23.         aa = Split(t(i), ",")
    
24.         For jj = 15 To UBound(Arr, 2)
    
25.             If jj <> UBound(Arr, 2) - 1 Then
    
26.             For j = 0 To UBound(aa)
    
27.                 .Cells(i + 3, jj - 12) = .Cells(i + 3, jj - 12) + Arr(aa(j), jj)
    
28.             Next
    
29.             Else
    
30.                 .Cells(i + 3, jj - 12) = Arr(aa(0), jj)
    
31.             End If
    
32.         Next
    
33.     Else
    
34.         For jj = 15 To UBound(Arr, 2)
    
35.             If jj <> UBound(Arr, 2) - 1 Then
    
36.             For j = 0 To UBound(aa)
    
37.                 .Cells(i + 3, jj - 12) = .Cells(i + 3, jj - 12) + Arr(t(i), jj)
    
38.             Next
    
39.             Else
    
40.                 .Cells(i + 3, jj - 12) = Arr(t(i), jj)
    
41.             End If
    
42.         Next
    
43.     End If
    
44. Next
    
45. End With
    
46. k1 = d1.keys: t1 = d1.items
    
47. With Sheet3
    
48. .[a3:g5000].ClearContents
    
49. .[a3].Resize(d1.Count) = Application.Transpose(k1)
    
50. .[a3].Resize(d1.Count).TextToColumns DataType:=xlDelimited, Comma:=True
    
51. For i = 0 To UBound(k1)
    
52.     t1(i) = Left(t1(i), Len(t1(i)) - 1)
    
53.     If InStr(t1(i), ",") Then
    
54.         aa = Split(t1(i), ",")
    
55.         For jj = 15 To UBound(Arr, 2)
    
56.             If jj <> UBound(Arr, 2) - 1 Then
    
57.             For j = 0 To UBound(aa)
    
58.                 .Cells(i + 3, jj - 12) = .Cells(i + 3, jj - 12) + Arr(aa(j), jj)
    
59.             Next
    
60.             Else
    
61.                 .Cells(i + 3, jj - 12) = Arr(aa(0), jj)
    
62.             End If
    
63.         Next
    
64.     Else
    
65.         For jj = 15 To UBound(Arr, 2)
    
66.             If jj <> UBound(Arr, 2) - 1 Then
    
67.             For j = 0 To UBound(aa)
    
68.                 .Cells(i + 3, jj - 12) = .Cells(i + 3, jj - 12) + Arr(t1(i), jj)
    
69.             Next
    
70.             Else
    
71.                 .Cells(i + 3, jj - 12) = Arr(t1(i), jj)
    
72.             End If
    
73.         Next
    
74.     End If
    
75. Next
    
76. End With
    
77. Application.DisplayAlerts = True
    
78. 
    
79. End Sub
    

复制代码

蓝桥玄霜

请见附件。

hlly888

请教.rar (19.34 KB, 下载次数: 17)

2014-4-25 11:13 上传

点击文件名下载附件

djy888

谢谢各位老师！

LMY123

多条件多列分类汇总，d1(y) = d1(y) & i & ","