[已解决]数据统计修改

cyj153

数据统计2.zip (21.39 KB, 下载次数: 10)

2015-12-21 18:47 上传

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

最佳答案

月排行榜 / 总排行榜

grf1973

2015-12-22 13:33

1. Sub 统计2()
   
2.    arr = Sheets(1).Range("a1").CurrentRegion
   
3.    ReDim brr(1 To UBound(arr), 1 To 16)
   
4.    Set d = CreateObject("scripting.dictionary")
   
5.    For i = 3 To UBound(arr)
   
6.       x = arr(i, 5): y = arr(i, 26) '年级、等级
   
7.       If Len(x) Then
   
8.          If Not d.exists(x) Then
   
9.             n = n + 1
   
10.             d(x) = n
    
11.             brr(n, 1) = arr(i, 5)
    
12.             brr(n, 2) = arr(i, 6)
    
13.             brr(n, 3) = arr(i, 7)
    
14.          End If
    
15.          brr(d(x), 4) = brr(d(x), 4) + 1
    
16.          If Len(y) = 0 Then y = "未测试"
    
17.          x1 = x & y
    
18.          d(x1) = d(x1) + 1
    
19.          If InStr("优秀良好及格", y) > 0 Then
    
20.             x1 = x & "合格总数"
    
21.             d(x1) = d(x1) + 1
    
22.         End If
    
23.       End If
    
24.    Next
    
25.    With ActiveSheet
    
26.         .[a6:p300].ClearContents
    
27.         .[a6].Resize(n, 4) = brr
    
28.         crr = .[a4].Resize(n + 2, 16)
    
29.             For j = 5 To 15 Step 2
    
30.                 x = crr(1, j)
    
31.                 For i = 3 To UBound(crr)
    
32.                     y = crr(i, 1) & x
    
33.                     crr(i, j) = d(y)
    
34.                     If crr(i, j) * crr(i, 4) > 0 Then crr(i, j + 1) = crr(i, j) / crr(i, 4)
    
35.                 Next
    
36.             Next
    
37.         .[a4].Resize(n + 2, 16) = crr
    
38.     End With
    
39. End Sub
    

复制代码

跳转到最佳答案楼层

baksy

附件

tzjx200521

1. Sub test()
   
2.     Dim x As Integer, arr, m As Integer, brr, yx, lh, jg, bjg, wcs, k
   
3.     Set d = CreateObject("scripting.dictionary")
   
4.     m = Sheets("高三年级").Range("e65536").End(3).Row
   
5.     arr = Sheets("高三年级").Range("e1:z" & m)
   
6.     For x = 2 To UBound(arr)
   
7.         If arr(x, 1) <> "" Then
   
8.             d(arr(x, 1)) = 1
   
9.         End If
   
10.     Next
    
11.     brr = d.keys
    
12.     With Sheets("表3")
    
13.         .Range("a6").Resize(UBound(brr) + 1, 1) = Application.Transpose(brr)
    
14.         crr = .Range("a6:q" & Sheets("表3").Range("a65536").End(3).Row)
    
15.         yx = 0
    
16.         lh = 0
    
17.         jg = 0
    
18.         bjg = 0
    
19.         wcs = 0
    
20.         k = 0
    
21.         For x = 1 To UBound(crr)
    
22.             For y = 1 To UBound(arr)
    
23.                 If crr(x, 1) = arr(y, 1) Then
    
24.                     crr(x, 2) = arr(y, 2)
    
25.                     crr(x, 3) = arr(y, 3)
    
26.                     k = k + 1
    
27.                     If arr(y, 22) = "优秀" Then yx = yx + 1
    
28.                     If arr(y, 22) = "良好" Then lh = lh + 1
    
29.                     If arr(y, 22) = "及格" Then jg = jg + 1
    
30.                     If arr(y, 22) = "不及格" Then bjg = bjg + 1
    
31.                     If arr(y, 22) = "未测试" Then wcs = wcs + 1
    
32.                 End If
    
33.             Next
    
34.             .Cells(x + 5, 1) = crr(x, 1)
    
35.             .Cells(x + 5, 2) = crr(x, 2)
    
36.             .Cells(x + 5, 3) = crr(x, 3)
    
37.             .Cells(x + 5, 4) = k
    
38. 
    
39.             .Cells(x + 5, 5) = yx
    
40.             .Cells(x + 5, 6) = yx / k
    
41.             .Cells(x + 5, 6).NumberFormatLocal = "0.00%"
    
42. 
    
43.             .Cells(x + 5, 7) = lh
    
44.             .Cells(x + 5, 8) = lh / k
    
45.             .Cells(x + 5, 8).NumberFormatLocal = "0.00%"
    
46. 
    
47.             .Cells(x + 5, 9) = jg
    
48.             .Cells(x + 5, 10) = jg / k
    
49.             .Cells(x + 5, 10).NumberFormatLocal = "0.00%"
    
50. 
    
51.             .Cells(x + 5, 11) = bjg
    
52.             .Cells(x + 5, 12) = bjg / k
    
53.             .Cells(x + 5, 12).NumberFormatLocal = "0.00%"
    
54. 
    
55.             .Cells(x + 5, 13) = bjg
    
56.             .Cells(x + 5, 14) = bjg / k
    
57.             .Cells(x + 5, 14).NumberFormatLocal = "0.00%"
    
58. 
    
59.             .Cells(x + 5, 15) = yx + lh + jg
    
60.             .Cells(x + 5, 16) = (yx + lh + jg) / k
    
61.             .Cells(x + 5, 16).NumberFormatLocal = "0.00%"
    
62. 
    
63.             yx = 0
    
64.             lh = 0
    
65.             jg = 0
    
66.             bjg = 0
    
67.             wcs = 0
    
68.             k = 0
    
69.         Next
    
70.     End With
    
71. 
    
72. End Sub
    
73. 
    

复制代码

请测试，看看是不是这样？

grf1973

1. Sub 统计2()
   
2.    arr = Sheets(1).Range("a1").CurrentRegion
   
3.    ReDim brr(1 To UBound(arr), 1 To 16)
   
4.    Set d = CreateObject("scripting.dictionary")
   
5.    For i = 3 To UBound(arr)
   
6.       x = arr(i, 5): y = arr(i, 26) '年级、等级
   
7.       If Len(x) Then
   
8.          If Not d.exists(x) Then
   
9.             n = n + 1
   
10.             d(x) = n
    
11.             brr(n, 1) = arr(i, 5)
    
12.             brr(n, 2) = arr(i, 6)
    
13.             brr(n, 3) = arr(i, 7)
    
14.          End If
    
15.          brr(d(x), 4) = brr(d(x), 4) + 1
    
16.          If Len(y) = 0 Then y = "未测试"
    
17.          x1 = x & y
    
18.          d(x1) = d(x1) + 1
    
19.          If InStr("优秀良好及格", y) > 0 Then
    
20.             x1 = x & "合格总数"
    
21.             d(x1) = d(x1) + 1
    
22.         End If
    
23.       End If
    
24.    Next
    
25.    With ActiveSheet
    
26.         .[a6:p300].ClearContents
    
27.         .[a6].Resize(n, 4) = brr
    
28.         crr = .[a4].Resize(n + 2, 16)
    
29.             For j = 5 To 15 Step 2
    
30.                 x = crr(1, j)
    
31.                 For i = 3 To UBound(crr)
    
32.                     y = crr(i, 1) & x
    
33.                     crr(i, j) = d(y)
    
34.                     If crr(i, j) * crr(i, 4) > 0 Then crr(i, j + 1) = crr(i, j) / crr(i, 4)
    
35.                 Next
    
36.             Next
    
37.         .[a4].Resize(n + 2, 16) = crr
    
38.     End With
    
39. End Sub
    

复制代码