[已解决]请教大神：怎样把公式转换为VBA代码？谢！

白云无尽9987 · 发表于 2016-1-15 11:30

QCW911 · 发表于 2016-1-15 17:34

有偿编写，有意加QQ 57726980

grf1973 · 发表于 2016-1-18 10:32

Sub 汇总1()
Dim Rng As Range
Application.ScreenUpdating = False
r = [a65536].End(3).Row
Range("u6:y" & r).ClearContents
arr = Range("a6:y" & r)
Set d = CreateObject("scripting.dictionary")
For i = 1 To UBound(arr)
For j = 6 To 20
If Val(arr(i, j)) > 0 Then
arr(i, 21) = arr(i, 21) + arr(i, j) '总分
arr(i, 23) = arr(i, 23) + 1 '考试科数
If arr(i, j) >= 60 Then arr(i, 22) = arr(i, 22) + 1 '及格科数
End If
Next
If Len(arr(i, 4)) > 0 Then '有姓名
arr(i, 21) = Val(arr(i, 21))
x = arr(i, 1): y = x & arr(i, 2)
Set Rng = Cells(i + 5, 21)
If Not d.exists(x) Then Set d(x) = Rng Else Set d(x) = Union(d(x), Rng) '同年级所在的Range
If Not d.exists(y) Then Set d(y) = Rng Else Set d(y) = Union(d(y), Rng) '同班级所在的Range
End If
Next
Range("a6:y" & [a65536].End(3).Row) = arr '运行结果：总分，考试科数，及格科数
For i = 1 To UBound(arr)
x = arr(i, 1): y = x & arr(i, 2)
If Len(arr(i, 4)) > 0 Then '有姓名
arr(i, 24) = Application.WorksheetFunction.Rank(arr(i, 21), d(x)) '年级排名
arr(i, 25) = Application.WorksheetFunction.Rank(arr(i, 21), d(y)) '班级排名
End If
Next
Range("a6:y" & r) = arr
Application.ScreenUpdating = True
End Sub

复制代码

grf1973 · 发表于 2016-1-18 10:33

Sub 汇总()
Application.ScreenUpdating = False
r = [a65536].End(3).Row
Range("u6:y" & r).ClearContents
arr = Range("a6:y" & r)
For i = 1 To UBound(arr)
For j = 6 To 20
If Val(arr(i, j)) > 0 Then
arr(i, 21) = arr(i, 21) + arr(i, j) '总分
arr(i, 23) = arr(i, 23) + 1 '考试科数
If arr(i, j) >= 60 Then arr(i, 22) = arr(i, 22) + 1 '及格科数
End If
Next
Next
Range("a6:y" & [a65536].End(3).Row) = arr '运行结果：总分，考试科数，及格科数
Range("a6:y" & [a65536].End(3).Row).Sort key1:=[a1], key2:=[U1], order2:=xlDescending '按级+总分排序，计算级名
arr = Range("a6:y" & r)
arr(1, 24) = 1: n = 1
For i = 2 To UBound(arr)
If arr(i, 1) = arr(i - 1, 1) Then
If Len(arr(i, 4)) > 0 Then '有姓名
n = n + 1
arr(i, 24) = n
If arr(i, 21) = arr(i - 1, 21) Then arr(i, 24) = arr(i - 1, 24)
End If
Else
n = 1
arr(i, 24) = n
End If
Next
Range("a6:y" & r) = arr '运行结果：年级排名
Range("a6:y" & [a65536].End(3).Row).Sort key1:=[a1], key2:=[b1], key3:=[U1], order3:=xlDescending '按级+班+总分排序，计算班名
arr = Range("a6:y" & r)
arr(1, 25) = 1: n = 1
For i = 2 To UBound(arr)
If arr(i, 2) = arr(i - 1, 2) Then
If Len(arr(i, 4)) > 0 Then '有姓名
n = n + 1
arr(i, 25) = n
If arr(i, 21) = arr(i - 1, 21) Then arr(i, 25) = arr(i - 1, 25)
End If
Else
n = 1
arr(i, 25) = n
End If
Next
Range("a6:y" & r) = arr '运行结果：班级排名
Range("a6:y" & [a65536].End(3).Row).Sort key1:=[c1] '按序号排序，恢复原序
Application.ScreenUpdating = True
End Sub

复制代码

grf1973 · 发表于 2016-1-18 10:36

提供了两种方法供参考。方法1是用字典存放同年级或是同年同班的总分，然后用工作表函数Rank得出相应排名；方法2是先按年级+总分排名，再按年级+班级+总分排名，得出名次后恢复原序。
方法1代码比较简洁，但要用到字典的概念。方法2比较直观，易于理解，但代码长一点，且因为多次排序可能速度慢一点。

白云无尽9987 · 发表于 2016-1-27 12:09

本帖最后由白云无尽9987 于 2016-1-27 12:46 编辑

888.rar (598.35 KB, 下载次数: 8)

2016-1-27 12:46 上传
点击文件名下载附件 grf1973 发表于 2016-1-18 10:32

........................

grf1973 · 发表于 2016-1-27 13:50

改好啦。看来字典的用法你还没真正掌握。

grf1973 · 发表于 2016-1-27 13:52

另外折算方法也小改了一下，直接写成iif形式。
x=iif(true,a,b) 就等于
if true then x=a else x=b
折算总分也改成=语数外+物折+化折+。。。其他折

白云无尽9987 · 发表于 2016-1-27 16:02

本帖最后由白云无尽9987 于 2016-1-27 16:33 编辑

grf1973 发表于 2016-1-27 13:50
改好啦。看来字典的用法你还没真正掌握。

多谢大神多次帮教，...……
④像V8、V15、V32里的及格科数“0”能否显示出来？
谢！

grf1973 · 发表于 2016-1-27 16:21

vba编辑界面下，点工具--引用，把里面显示“丢失”的点掉。

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