VBA实现统计功能

wxcbit

根据sheet1中的相关数据，生成sheet2中数据，研究了半天搞不定啊，哪位大虾帮帮忙！
详见附件 附件.rar (13.04 KB, 下载次数: 14)

2013-3-4 15:04 上传

点击文件名下载附件

nkgsm

这样的需求何必用VBA，直接用透视即可，不过，在源表上要增加两列计算列。

wxcbit

nkgsm 发表于 2013-3-4 15:37
这样的需求何必用VBA，直接用透视即可，不过，在源表上要增加两列计算列。

正在研究vba，所以希望能够开发设计。

蓝桥玄霜

1. Sub lqxs()
   
2. Dim Arr, i&, j&, aa, Brr, ii&, n&, rq, ks, ts
   
3. Dim d, k, t
   
4. Set d = CreateObject("Scripting.Dictionary")
   
5. Sheet2.Activate
   
6. [a2:f5000].ClearContents
   
7. Arr = Sheet1.[a1].CurrentRegion
   
8. ReDim Brr(1 To UBound(Arr), 1 To 6)
   
9. For i = 2 To UBound(Arr)
   
10.     x = Arr(i, 2) & "," & Arr(i, 3)
    
11.     d(x) = d(x) & i & ","
    
12. Next
    
13. k = d.keys
    
14. t = d.items
    
15. For i = 0 To UBound(k)
    
16. If i = 33 Then Stop
    
17.     t(i) = Left(t(i), Len(t(i)) - 1)
    
18.     If InStr(t(i), ",") Then
    
19.         aa = Split(t(i), ",")
    
20.             n = n + 1
    
21.             For j = 1 To 4
    
22.                 Brr(n, j) = Arr(aa(0), j)
    
23.             Next
    
24.         For ii = 0 To UBound(aa)
    
25.             Brr(n, 5) = Brr(n, 5) + Arr(aa(ii), 5) * Arr(aa(ii), 6)
    
26.         Next
    
27.     Else
    
28.         n = n + 1
    
29.         For j = 1 To 4
    
30.             Brr(n, j) = Arr(t(i), j)
    
31.         Next
    
32.         Brr(n, 5) = Arr(t(i), 5) * Arr(t(i), 6)
    
33.     End If
    
34. Next
    
35. [a2].Resize(n, 6) = Brr
    
36. rq = [a2].Value
    
37. ks = DateSerial(Year(rq) - 1, 12, 31)
    
38. ts = DateDiff("d", ks, rq)
    
39. [f2].Formula = "=rc[-1]/" & ts
    
40. [f2].AutoFill [f2].Resize(n, 1)
    
41. End Sub

复制代码

蓝桥玄霜

请见附件。

kanshangniya

test1.rar (16.83 KB, 下载次数: 15)

2013-3-4 18:56 上传

点击文件名下载附件

运行附件看看，满足你的要求不

LMY123

d(x) = d(x) & i & ",",分类汇总