高考成绩上线VBA解决（感谢褚老师和小刀老师）

vvw123 · 发表于 2018-12-1 17:43

chxw68 发表于 2018-12-1 17:06
只写了上线代码，不知道结果正确与否，级排没看懂意思。

完全正确！谢谢褚老师。
总分的上线我看能不能自己解决！
再次致以崇高的敬意！谢谢！

vvw123 · 发表于 2018-12-1 17:47

一把小刀闯天下发表于 2018-12-1 17:22
'褚老师写了上线代码，我正好写了个排名，上线看上去晕，那就不写了，，，

'自己测试一下

完全正确！谢谢小刀老师！

一把小刀闯天下 · 发表于 2018-12-1 18:54

vvw123 发表于 2018-12-1 17:47
完全正确！谢谢小刀老师！

三楼你已确定了条件，排名就不是一件难事。其实就是根据条件不停的排序、排名而已，，，

vvw123 · 发表于 2018-12-1 19:02

一把小刀闯天下发表于 2018-12-1 18:54
三楼你已确定了条件，排名就不是一件难事。其实就是根据条件不停的排序、排名而已，，，

谢谢小刀老师指点迷津。原本的成绩分析表纯公式，而且很多是数组公式，修改一个数据后要运算一段时间。但是对于vba，纯粹是拿来主义，感谢所有老师的包容和厚爱！谢谢你们，尤其是褚老师，多次烦扰。谢谢！

chxw68 · 发表于 2018-12-1 21:09

Sub test()
Dim r%, i%
Dim arr, brr
Dim d As Object
Set d = CreateObject("scripting.dictionary")
With Worksheets("设置")
r = .Cells(.Rows.Count, 1).End(xlUp).Row
arr = .Range("a2:g" & r)
vs = [{"专科","本科","重点","前X名","第一名"}]
End With
For i = 2 To UBound(arr)
If Not d.exists(arr(i, 1)) Then
Set d(arr(i, 1)) = CreateObject("scripting.dictionary")
End If
Select Case arr(i, 2)
Case "物理", "政治"
km = "物政"
Case "化学", "历史"
km = "化历"
Case "生物", "地理"
km = "生地"
Case "理数", "文数"
km = "数学"
Case "理综", "文综"
km = "综合"
Case Else
km = arr(i, 2)
End Select
d(arr(i, 1))(km) = Array(arr(i, 7), arr(i, 6), arr(i, 5), arr(i, 4), arr(i, 3))
Next
With Worksheets("成绩表")
r = .Cells(.Rows.Count, 3).End(xlUp).Row
.Range("o4:ag" & r).ClearContents
arr = .Range("a2:ag" & r)
For i = 3 To UBound(arr)
If d.exists(arr(i, 3)) Then
For j = 7 To 14
If d(arr(i, 3)).exists(arr(1, j)) Then
brr = d(arr(i, 3))(arr(1, j))
n = Application.Match(arr(i, j), brr)
If Not IsError(n) Then
If j = 14 Then
arr(i, 17) = vs(n)
Else
arr(i, j * 2 + 7) = vs(n)
End If
End If
End If
Next
End If
Next
For j = 7 To 14
d.RemoveAll
For i = 3 To UBound(arr)
If Len(arr(i, j)) <> 0 Then
If Not d.exists(arr(i, 3)) Then
Set d(arr(i, 3)) = CreateObject("scripting.dictionary")
End If
d(arr(i, 3))(arr(i, j)) = d(arr(i, 3))(arr(i, j)) + 1
End If
Next
For Each aa In d.keys
nn = 1
kk = d(aa).keys
For k = 0 To UBound(kk)
mm = Application.Large(kk, k + 1)
ss = d(aa)(mm)
d(aa)(mm) = nn
nn = nn + ss
Next
Next
For i = 3 To UBound(arr)
If Len(arr(i, j)) <> 0 Then
If j = 14 Then
arr(i, 15) = d(arr(i, 3))(arr(i, j))
Else
arr(i, j * 2 + 6) = d(arr(i, 3))(arr(i, j))
End If
End If
Next
Next
d.RemoveAll
For i = 3 To UBound(arr)
If Len(arr(i, 14)) <> 0 Then
If Not d.exists(arr(i, 3)) Then
Set d(arr(i, 3)) = CreateObject("scripting.dictionary")
End If
If Not d(arr(i, 3)).exists(arr(i, 5)) Then
Set d(arr(i, 3))(arr(i, 5)) = CreateObject("scripting.dictionary")
End If
d(arr(i, 3))(arr(i, 5))(arr(i, 14)) = d(arr(i, 3))(arr(i, 5))(arr(i, 14)) + 1
End If
Next
For Each aa In d.keys
For Each bb In d(aa).keys
nn = 1
kk = d(aa)(bb).keys
For k = 0 To UBound(kk)
mm = Application.Large(kk, k + 1)
ss = d(aa)(bb)(mm)
d(aa)(bb)(mm) = nn
nn = nn + ss
Next
Next
Next
For i = 3 To UBound(arr)
If Len(arr(i, 14)) <> 0 Then
arr(i, 16) = d(arr(i, 3))(arr(i, 5))(arr(i, 14))
End If
Next
.Range("a2").Resize(UBound(arr), UBound(arr, 2)) = arr
End With
End Sub

复制代码

chxw68 · 发表于 2018-12-1 21:11

本帖最后由 chxw68 于 2018-12-1 22:29 编辑

两问都写完了。借此贴向勤劳的一把小刀老师致敬！

vvw123 · 发表于 2018-12-1 21:41

chxw68 发表于 2018-12-1 21:09

谢谢褚老师指点迷津。原本的成绩分析表纯公式，而且很多是数组公式，修改一个数据后要运算一段时间。但是对于vba，纯粹是拿来主义，感谢所有老师的包容和厚爱！谢谢你，褚老师，多次烦扰。谢谢！

v111v111v · 发表于 2019-6-2 12:39

本帖最后由 v111v111v 于 2019-6-2 12:41 编辑

看看这个http://www.gswycjc.com/article/show.asp?id=10

		自动登录	找回密码
密码			免费注册

[已解决] 高考成绩上线VBA解决（感谢褚老师和小刀老师）

评分

评分

评分