|
|
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件 ★ 免费下载 ★ ★ 使用帮助★
Sub 统计学校排名()
Application.ScreenUpdating = False
Dim ar As Variant
Dim d As Object, dc As Object
Set d = CreateObject("scripting.dictionary")
Set dc = CreateObject("scripting.dictionary")
Set dic = CreateObject("scripting.dictionary")
With Sheets("对照表")
cr = .Range("a1:c17")
End With
For i = 2 To UBound(cr)
d(cr(i, 1)) = i
Next i
With Sheets("学校排名")
r = 200
y = .Cells(2, Columns.Count).End(xlToLeft).Column
If r < 3 Or y < 3 Then MsgBox "学校排名字段为空！": End
.UsedRange.Offset(2).Borders.LineStyle = 0
.UsedRange.Offset(2).Interior.ColorIndex = 0
.UsedRange.Offset(2) = Empty
ar = .Range(.Cells(2, 1), .Cells(r, y))
For j = 3 To 13 Step 2
dc(ar(1, j)) = j
Next j
k = 1
For Each sh In Sheets(Array("语文统计分析", "数学统计分析", "英语统计分析", "科学统计分析"))
mc = sh.Name
rs = sh.Cells(Rows.Count, 1).End(xlUp).Row
sh.Range("a3:p" & rs).Sort Key1:=sh.[a3], Order1:=xlAscending, Header:=xlYes, Key2:=sh.[c3], Order2:=xlAscending, Header:=xlYes 'xlDescending
br = sh.Range("a1:p" & rs)
mc = sh.Name
For i = 4 To UBound(br)
If br(i, 1) <> "" And br(i, 2) <> "" And br(i, 3) <> "" Then
zf_1 = br(i, 2)
xh_1 = d(zf_1)
br(i, 2) = cr(xh_1, 2) & "年级"
zf_2 = br(i, 3)
xh_2 = d(zf_2)
br(i, 3) = cr(xh_2, 2) & "班"
zd = br(i, 1) & "|" & br(i, 3) '''学校班级
t = dc(zd)
If t = "" Then
k = k + 1
dc(zd) = k
t = k
ar(k, 1) = br(i, 1)
ar(k, 2) = br(i, 3)
If Not dic.exists(ar(k, 1)) Then Set dic(ar(k, 1)) = CreateObject("scripting.dictionary")
dic(ar(k, 1))(k) = k
End If
zf = br(i, 2) & br(3, 15)
lh = dc(zf)
If lh <> "" Then
ar(t, lh) = ar(t, lh) + Val(br(i, 15))
ar(t, lh + 1) = ar(t, lh + 1) + Val(br(i, 16))
End If
End If
Next i
Next sh
Set d = Nothing
Set dc = Nothing
m = dic.Count
yy = 2
For Each kc In dic.keys
yy = yy + 1
mr = dic(kc).keys
x = mr(0)
For Each kk In dic(kc).keys
ar(x, 16) = ar(x, 16) + 1
For j = 4 To 14 Step 2
ar(x, 15) = ar(x, 15) + ar(kk, j)
Next j
ar(x, 17) = ar(x, 15) / ar(x, 16)
.Cells(kk + 1, 15).Resize(1, 4).Interior.ColorIndex = yy
.Cells(kk + 1, 1).Resize(1, 2).Interior.ColorIndex = yy
Next kk
Next kc
.Cells(2, 1).Resize(k, y) = ar
.Cells(2, 1).Resize(k, y).Borders.LineStyle = 1
For i = 3 To k + 1
If .Cells(i, 17) <> "" Then
.Cells(i, 18).FormulaR1C1 = "=IF(RC[-1]="""","""",RANK(RC[-1],R3C17:R" & k + 1 & "C17,1))"
End If
Next i
End With
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub
''16,7,21,35
|
|
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2024-5-12 06:16
楼主
，用你这个，一点按钮消失了