[已解决]再求：数据统计

cyj153

数据统计6.zip (6.67 KB, 下载次数: 16)

2016-1-9 23:47 上传

点击文件名下载附件
谢谢！

最佳答案

月排行榜 / 总排行榜

dsmch

2016-1-10 09:38

1. Sub Macro1()
   
2. Dim arr, brr, crr, d, i&, j%, s&, s2&
   
3. Set d = CreateObject("scripting.dictionary")
   
4. arr = Sheet3.[f2:g84]
   
5. brr = Sheet2.[a3:t3]
   
6. w = Array(0, 10, 20, 30, 40, 50, 60, 70, 80, 90, 100, 110, 120, 130, 140)
   
7. w2 = Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15)
   
8. ReDim crr(1 To 20000, 1 To UBound(brr, 2))
   
9. For i = 1 To UBound(arr)
   
10.     If Not d.exists(arr(i, 1)) Then
    
11.         s = s + 2
    
12.         d(arr(i, 1)) = s
    
13.         crr(s - 1, 1) = arr(i, 1)
    
14.         crr(s - 1, 2) = "人数"
    
15.         crr(s, 2) = "累加"
    
16.         crr(s - 1, 18) = arr(i, 2)
    
17.         crr(s - 1, 19) = arr(i, 2)
    
18.     End If
    
19.     s2 = d(arr(i, 1))
    
20.     n = 18 - Application.Lookup(arr(i, 2), w, w2)
    
21.     crr(s2 - 1, n) = crr(s2 - 1, n) + 1
    
22.     If arr(i, 2) > crr(s2 - 1, 18) Then crr(s2 - 1, 18) = arr(i, 2)
    
23.     If arr(i, 2) < crr(s2 - 1, 19) Then crr(s2 - 1, 19) = arr(i, 2)
    
24.     crr(s2 - 1, 20) = crr(s2 - 1, 20) + 1
    
25.     If n = 3 Then crr(s2, n) = crr(s2 - 1, n)
    
26. Next
    
27. For i = 1 To s - 1 Step 2
    
28.     For j = 4 To 17
    
29.         crr(i + 1, j) = crr(i + 1, j - 1) + crr(i, j)
    
30.     Next
    
31. Next
    
32. Sheet2.Range("a4").Resize(s, UBound(crr, 2)) = crr
    
33. End Sub

复制代码

跳转到最佳答案楼层

dsmch

1. Sub Macro1()
   
2. Dim arr, brr, crr, d, i&, j%, s&, s2&
   
3. Set d = CreateObject("scripting.dictionary")
   
4. arr = Sheet3.[f2:g84]
   
5. brr = Sheet2.[a3:t3]
   
6. w = Array(0, 10, 20, 30, 40, 50, 60, 70, 80, 90, 100, 110, 120, 130, 140)
   
7. w2 = Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15)
   
8. ReDim crr(1 To 20000, 1 To UBound(brr, 2))
   
9. For i = 1 To UBound(arr)
   
10.     If Not d.exists(arr(i, 1)) Then
    
11.         s = s + 2
    
12.         d(arr(i, 1)) = s
    
13.         crr(s - 1, 1) = arr(i, 1)
    
14.         crr(s - 1, 2) = "人数"
    
15.         crr(s, 2) = "累加"
    
16.         crr(s - 1, 18) = arr(i, 2)
    
17.         crr(s - 1, 19) = arr(i, 2)
    
18.     End If
    
19.     s2 = d(arr(i, 1))
    
20.     n = 18 - Application.Lookup(arr(i, 2), w, w2)
    
21.     crr(s2 - 1, n) = crr(s2 - 1, n) + 1
    
22.     If arr(i, 2) > crr(s2 - 1, 18) Then crr(s2 - 1, 18) = arr(i, 2)
    
23.     If arr(i, 2) < crr(s2 - 1, 19) Then crr(s2 - 1, 19) = arr(i, 2)
    
24.     crr(s2 - 1, 20) = crr(s2 - 1, 20) + 1
    
25.     If n = 3 Then crr(s2, n) = crr(s2 - 1, n)
    
26. Next
    
27. For i = 1 To s - 1 Step 2
    
28.     For j = 4 To 17
    
29.         crr(i + 1, j) = crr(i + 1, j - 1) + crr(i, j)
    
30.     Next
    
31. Next
    
32. Sheet2.Range("a4").Resize(s, UBound(crr, 2)) = crr
    
33. End Sub

复制代码

grf1973

1. Sub Macro1()
   
2.     Dim arr, brr, d, i&, j%, k%, c%
   
3.     Set d = CreateObject("scripting.dictionary")
   
4.     arr = Sheet3.Range("f2:g" & Sheet3.[f65536].End(3).Row)
   
5.     With ActiveSheet
   
6.         .[c4:t15].ClearContents
   
7.         brr = .Range("a4:t15")
   
8.         For i = 1 To UBound(brr) Step 2
   
9.             d(brr(i, 1)) = i   '根据班级得出行数
   
10.             brr(i, 19) = 200         '设个大值以便比较最小分
    
11.         Next
    
12.    
    
13.         For i = 1 To UBound(arr)
    
14.             k = d(arr(i, 1))
    
15.             If k > 0 Then
    
16.                 cj = arr(i, 2): c = 17 - Int(cj / 10)     '根据成绩得出要填充的列数
    
17.                 If cj > 0 Then brr(k, c) = brr(k, c) + 1  '分数段人数
    
18.                 If cj > 0 Then brr(k, 20) = brr(k, 20) + 1     '参考人数
    
19.                 If cj > brr(k, 18) Then brr(k, 18) = cj     '最大分
    
20.                 If cj < brr(k, 19) Then brr(k, 19) = cj     '最小分
    
21.             End If
    
22.         Next
    
23.    
    
24.         For i = 1 To UBound(brr) Step 2       '计算累计数
    
25.             For j = 3 To 17
    
26.                 brr(i + 1, j) = Val(brr(i + 1, j - 1)) + Val(brr(i, j))
    
27.                 If brr(i + 1, j) = 0 Then brr(i + 1, j) = ""
    
28.             Next
    
29.         Next
    
30.         .Range("a4:t15") = brr      '显示结果
    
31.     End With
    
32. End Sub
    

复制代码