楼主
kevinchengcw |
Q: 如何用vba代码统计乱序的学生成绩中各班级的科目最低分信息？
A: 代码如下：- Sub test()
- Dim Dic As Object, Arr, Result, Rng As Range, N&, I&, Str$
- Set Dic = CreateObject("scripting.dictionary") '创建字典项目
- ReDim Result(1 To 9, 1 To 1) '重定义结果数组
- Arr = Split("a,b,c,d,e,f,g,q,u,y", ",") '赋值要提取内容的列的数组
- For N = LBound(Arr) To UBound(Arr) - 3 '循环写入信息标题
- Result(N + 1, 1) = Cells(1, Arr(N)).Value
- Next N
- Result(8, 1) = "最低分科目" '写入科目及分数信息标题
- Result(9, 1) = "分数"
- For Each Rng In Range("F3:F" & Cells(Rows.Count, "F").End(3).Row) '循环姓名列各单元格
- For N = UBound(Arr) - 2 To UBound(Arr) '循环科目列标
- If Cells(Rng.Row, Arr(N)) <> "" Then '如果分数不为空,则
- Str = Cells(Rng.Row, "C").Value & vbTab & Cells(Rng.Row, "D").Value & vbTab & Cells(1, Arr(N)) '组合年班及科目信息字符串
- If Dic.exists(Str) Then '如果已经存在该字项目,则
- If Cells(Rng.Row, Arr(N)) < Result(UBound(Result), Dic(Str)) Then '如果当前行科目分数小于已存数据,则循环更新结果数据为当前行数据
- For I = LBound(Arr) To UBound(Arr) - 3
- Result(I + 1, Dic(Str)) = Cells(Rng.Row, Arr(I))
- Next I
- Result(9, Dic(Str)) = Cells(Rng.Row, Arr(N))
- End If
- Else
- ReDim Preserve Result(1 To 9, 1 To UBound(Result, 2) + 1) '如果未存在该字典项目,则为结果数组添加一列,并在字典中添加该项目,记录下在结果数组中的列号,并循环将数据写入对应位置
- Dic.Add Str, UBound(Result, 2)
- For I = LBound(Arr) To UBound(Arr) - 3
- Result(I + 1, Dic(Str)) = Cells(Rng.Row, Arr(I))
- Next I
- Result(8, Dic(Str)) = Cells(1, Arr(N))
- Result(9, Dic(Str)) = Cells(Rng.Row, Arr(N))
- End If
- End If
- Next N
- Next Rng
- With [ah2].Resize(UBound(Result, 2), UBound(Result)) '将结果写入以ah2为左上角的区域(先清空整列再写入数组数据)
- .EntireColumn.ClearContents
- .Value = Application.Transpose(Result)
- End With
- Set Dic = Nothing '清空字典项目
- End Sub
详见二楼附件及素材源帖. |
学生数据库2011春.rar