[已解决]统计

abc153

统计与排名4.zip (128.68 KB, 下载次数: 24)

2015-4-8 12:08 上传

点击文件名下载附件
原数据列改变后，VBA的代码如何修改，谢谢老师帮忙！

最佳答案

月排行榜 / 总排行榜

grf1973

2015-4-8 15:41

一不做二不休，搞个通用的

1. Sub tt()
   
2.     Set d = CreateObject("scripting.dictionary")
   
3.     Set d1 = CreateObject("scripting.dictionary")
   
4.     With Sheets("3")
   
5.         nj = .Rows(1).Find("年级").Column
   
6.         xm = .Rows(1).Find("项目").Column
   
7.         bj = .Rows(1).Find("班级").Column
   
8.         mc = .Rows(1).Find("名次").Column
   
9.         jl = .Rows(1).Find("纪录").Column
   
10.         fz = .Rows(1).Find("分值").Column
    
11.         R = .Cells(65536, xm).End(3).Row
    
12.         Arr = .Range("a1:p" & R)
    
13.     End With
    
14.     With Sheet1
    
15.         Zb = .[d3]        '组别
    
16.         For i = 2 To UBound(Arr)
    
17.             If Arr(i, nj) = Zb And Arr(i, mc) > 0 Then
    
18.                 d(Arr(i, bj)) = d(Arr(i, bj)) + Arr(i, fz)    '班级的分值
    
19.                 x = Arr(i, bj) & Arr(i, mc)     '班级+名次为key
    
20.                 d1(x) = d1(x) + 1           '班级各名次人数
    
21.                 If Arr(i, jl) = "破" Then d1(Arr(i, bj) & "纪录") = d1(Arr(i, bj) & "纪录") + 1
    
22.             End If
    
23.         Next
    
24.         .[a6].Resize(100, 100).ClearContents
    
25.         .[a6].Resize(d.Count) = Application.Transpose(d.keys)
    
26.         Brr = .[a5].CurrentRegion
    
27.         For i = 2 To UBound(Brr)
    
28.             Brr(i, 2) = d1(Brr(i, 1) & "纪录")    '破纪录人数
    
29.             For j = 3 To 10         '各名次人数
    
30.                 x = Brr(i, 1) & j - 2
    
31.                 Brr(i, j) = d1(x)
    
32.             Next
    
33.             Brr(i, 11) = d(Brr(i, 1))          '班级分值
    
34.         Next
    
35.         .[a5].CurrentRegion = Brr
    
36.         .[a6].Resize(d.Count, 11).Sort key1:=.[k6], order1:=xlDescending          '按分值排序
    
37.         .[L6].Resize(d.Count, 1).Formula = "=RANK(RC[-1],R6C[-1]:R" & 6 + d.Count - 1 & "C[-1])"         '公式名次
    
38.     End With
    
39. End Sub

复制代码

跳转到最佳答案楼层

grf1973

一不做二不休，搞个通用的

1. Sub tt()
   
2.     Set d = CreateObject("scripting.dictionary")
   
3.     Set d1 = CreateObject("scripting.dictionary")
   
4.     With Sheets("3")
   
5.         nj = .Rows(1).Find("年级").Column
   
6.         xm = .Rows(1).Find("项目").Column
   
7.         bj = .Rows(1).Find("班级").Column
   
8.         mc = .Rows(1).Find("名次").Column
   
9.         jl = .Rows(1).Find("纪录").Column
   
10.         fz = .Rows(1).Find("分值").Column
    
11.         R = .Cells(65536, xm).End(3).Row
    
12.         Arr = .Range("a1:p" & R)
    
13.     End With
    
14.     With Sheet1
    
15.         Zb = .[d3]        '组别
    
16.         For i = 2 To UBound(Arr)
    
17.             If Arr(i, nj) = Zb And Arr(i, mc) > 0 Then
    
18.                 d(Arr(i, bj)) = d(Arr(i, bj)) + Arr(i, fz)    '班级的分值
    
19.                 x = Arr(i, bj) & Arr(i, mc)     '班级+名次为key
    
20.                 d1(x) = d1(x) + 1           '班级各名次人数
    
21.                 If Arr(i, jl) = "破" Then d1(Arr(i, bj) & "纪录") = d1(Arr(i, bj) & "纪录") + 1
    
22.             End If
    
23.         Next
    
24.         .[a6].Resize(100, 100).ClearContents
    
25.         .[a6].Resize(d.Count) = Application.Transpose(d.keys)
    
26.         Brr = .[a5].CurrentRegion
    
27.         For i = 2 To UBound(Brr)
    
28.             Brr(i, 2) = d1(Brr(i, 1) & "纪录")    '破纪录人数
    
29.             For j = 3 To 10         '各名次人数
    
30.                 x = Brr(i, 1) & j - 2
    
31.                 Brr(i, j) = d1(x)
    
32.             Next
    
33.             Brr(i, 11) = d(Brr(i, 1))          '班级分值
    
34.         Next
    
35.         .[a5].CurrentRegion = Brr
    
36.         .[a6].Resize(d.Count, 11).Sort key1:=.[k6], order1:=xlDescending          '按分值排序
    
37.         .[L6].Resize(d.Count, 1).Formula = "=RANK(RC[-1],R6C[-1]:R" & 6 + d.Count - 1 & "C[-1])"         '公式名次
    
38.     End With
    
39. End Sub

复制代码

grf1973

请看附件。

dsmch

1. Sub Macro1()
   
2. Dim arr, brr, d, i&, s&, n&
   
3. Set d = CreateObject("scripting.dictionary")
   
4. arr = Sheets("3").UsedRange
   
5. Sheet10.Activate
   
6. ReDim brr(1 To 1000, 1 To 13)
   
7. For i = 2 To UBound(arr)
   
8.     If arr(i, 11) <> "" Then
   
9.         If Not d.exists(arr(i, 9)) Then
   
10.             s = s + 1
    
11.             d(arr(i, 9)) = s
    
12.             brr(s, 1) = arr(i, 9)
    
13.             brr(s, 2 + arr(i, 11)) = 1
    
14.             brr(s, 11) = brr(s, 11) + arr(i, 13)
    
15.         Else
    
16.             n = d(arr(i, 9))
    
17.             brr(n, 2 + arr(i, 11)) = 1
    
18.             brr(n, 11) = brr(n, 11) + arr(i, 13)
    
19.         End If
    
20.     End If
    
21. Next
    
22. [a4:m1000] = ""
    
23. Range("a4").Resize(s, UBound(brr, 2)) = brr
    
24. Range("a3").CurrentRegion.Sort [k4], Order1:=xlDescending, Header:=xlGuess
    
25. End Sub

复制代码