楼主
0Mouse |
Q：如何分别统计每名教师授课班级的学生总人数同时列出各班人数的求和式且可即时更新呢？
问题预览图：
A：示例代码如下：- Private Sub Worksheet_Change(ByVal Target As Range)
- If Target.Column < 4 Then
- Dim arr, d1 As Object, i%, brr(1 To 1000, 1 To 1000), Ar(1 To 1000, 1 To 2), d2 As Object, j%, k%, crr, drr, m%, sr$
- Set d1 = CreateObject("scripting.dictionary")
- Set d2 = CreateObject("scripting.dictionary")
- arr = Range("A1").CurrentRegion
- For i = 2 To UBound(arr)
- If arr(i, 2) <> "" And arr(i, 3) <> "" Then
- If Not d1.exists(arr(i, 2)) Then
- d1.Add arr(i, 2), d1.Count + 1
- brr(d1.Count, 1) = arr(i, 2)
- brr(d1.Count, 2) = arr(i, 3)
- Ar(d1.Count, 1) = arr(i, 3)
- Ar(d1.Count, 2) = 2
- Else
- Ar(d1(arr(i, 2)), 1) = Ar(d1(arr(i, 2)), 1) + arr(i, 3)
- Ar(d1(arr(i, 2)), 2) = Ar(d1(arr(i, 2)), 2) + 1
- brr(d1(arr(i, 2)), Ar(d1(arr(i, 2)), 2)) = arr(i, 3)
- End If
- End If
- Next
- For j = 1 To d1.Count
- For k = 2 To UBound(arr)
- If brr(j, k) <> "" Then
- d2(brr(j, k)) = d2(brr(j, k)) + 1
- End If
- Next
- crr = d2.keys
- drr = d2.items
- For m = 0 To d2.Count - 1
- sr = sr & crr(m) & IIf(drr(m) > 1, "*" & drr(m), "") & "+"
- Next
- brr(j, 2) = Left(sr, Len(sr) - 1) & "=" & Ar(j, 1)
- sr = ""
- d2.RemoveAll
- Erase crr: Erase drr
- Next
- [F1:G1] = Array("老师名", "人数统计")
- [F2].Resize(d1.Count, 2) = brr
- Set d1 = Nothing
- Set d2 = Nothing
- Erase brr: Erase arr: Erase Ar
- End If
- End Sub
附件：
 分别统计每名教师授课班级的学生总人数同时列出各班人数的求和式且可即时更新.rar
|