如何通过类型判断学生应修课程不及格

wangwei819 · 发表于 2018-10-12 09:36

本帖最后由 wangwei819 于 2018-10-14 22:01 编辑

Sheet1表中是学生已经修读的课程和成绩
Sheet2表是每个类型应修的课程
Sheet3用于存放计算结果

注：学生多修的课程不论及格与不及格都不计入结果；应修课程但是没有修读（缺漏）的视为不及格课程统计在Sheet3里

如何通过类型判断学生应修课程不及格.zip (7.25 KB, 下载次数: 11)

chxw68 · 发表于 2018-10-12 09:59

Sub test()
Dim r%, i%, m%
Dim arr, brr(1 To 1000, 1 To 2)
Dim d As Object
Set d = CreateObject("scripting.dictionary")
Set d1 = CreateObject("scripting.dictionary")
With Worksheets("sheet2")
r = .UsedRange.Find(what:="*", LookIn:=xlValues, lookat:=xlWhole, searchorder:=xlByRows, searchdirection:=xlPrevious).Row
arr = .Range("a1:d" & r)
For j = 1 To UBound(arr, 2)
lx = Right(arr(1, j), 1)
Set d(lx) = CreateObject("scripting.dictionary")
For i = 2 To UBound(arr)
If Len(arr(i, j)) <> 0 Then
d(lx)(arr(i, j)) = ""
End If
Next
Next
End With
With Worksheets("sheet1")
r = .Cells(.Rows.Count, 1).End(xlUp).Row
arr = .Range("a2:d" & r)
For i = 1 To UBound(arr)
If Not d1.exists(arr(i, 2)) Then
Set d1(arr(i, 2)) = CreateObject("scripting.dictionary")
d1(arr(i, 2))(1) = arr(i, 1)
Set d1(arr(i, 2))(2) = CreateObject("scripting.dictionary")
End If
d1(arr(i, 2))(2)(arr(i, 3)) = arr(i, 4)
Next
End With
m = 0
For Each aa In d1.keys
lx = d1(aa)(1)
For Each bb In d(lx).keys
If d1(aa)(2).exists(bb) Then
If d1(aa)(2)(bb) < 60 Then
m = m + 1
brr(m, 1) = aa
brr(m, 2) = bb
End If
Else
m = m + 1
brr(m, 1) = aa
brr(m, 2) = bb
End If
Next
Next
With Worksheets("sheet3")
.UsedRange.Offset(1, 0).ClearContents
.Columns(1).NumberFormatLocal = "@"
.Range("a2").Resize(m, UBound(brr, 2)) = brr
End With
End Sub

复制代码

chxw68 · 发表于 2018-10-12 10:00

详见附件。

wdx223 · 发表于 2018-10-12 11:44

Sub test2()
Dim kc, data, i&, j&, xh, k
data = ThisWorkbook.Worksheets("Sheet2").UsedRange
Set kc = CreateObject("Scripting.Dictionary")
For i = 2 To UBound(data)
For j = 1 To UBound(data, 2)
If data(1, j) <> "" And data(i, j) <> "" Then
kc(data(1, j) & "") = kc(data(1, j) & "") & "," & data(i, j)
End If
Next j
Next i
data = ThisWorkbook.Worksheets("Sheet1").UsedRange
Set xh = CreateObject("Scripting.Dictionary")
For i = 2 To UBound(data)
If data(i, 2) <> "" And data(i, 1) <> "" Then
If Not xh.exists(data(i, 2) & "") Then xh(data(i, 2) & "") = kc("类型" & data(i, 1))
If data(i, 4) >= 60 Then
xh(data(i, 2) & "") = Replace(xh(data(i, 2) & ""), "," & data(i, 3), "")
End If
End If
Next i
For Each k In xh.keys
xh(k) = Right(xh(k), Len(xh(k)) - 1)
Next k
With ThisWorkbook.Worksheets("Sheet3")
.UsedRange.Offset(1, 0).ClearContents
.[A2].Resize(xh.Count, 1) = Application.Transpose(xh.keys)
.[B2].Resize(xh.Count, 1) = Application.Transpose(xh.items)
End With
End Sub

复制代码

wangwei819 · 发表于 2018-10-12 19:44

wdx223 发表于 2018-10-12 11:44

如果某一个学生完全及格且符合应修条件代码好像会报错

wdx223 · 发表于 2018-10-13 08:45

wangwei819 发表于 2018-10-12 19:44
如果某一个学生完全及格且符合应修条件代码好像会报错

Sub test2()
Dim kc, data, i&, j&, xh, k
data = ThisWorkbook.Worksheets("Sheet2").UsedRange
Set kc = CreateObject("Scripting.Dictionary")
For i = 2 To UBound(data)
For j = 1 To UBound(data, 2)
If data(1, j) <> "" And data(i, j) <> "" Then
kc(data(1, j) & "") = kc(data(1, j) & "") & "," & data(i, j)
End If
Next j
Next i
data = ThisWorkbook.Worksheets("Sheet1").UsedRange
Set xh = CreateObject("Scripting.Dictionary")
For i = 2 To UBound(data)
If data(i, 2) <> "" And data(i, 1) <> "" Then
If Not xh.exists(data(i, 2) & "") Then xh(data(i, 2) & "") = kc("类型" & data(i, 1))
If data(i, 4) >= 60 Then
xh(data(i, 2) & "") = Replace(xh(data(i, 2) & ""), "," & data(i, 3), "")
End If
End If
Next i
For Each k In xh.keys
If xh(k) <> "" Then xh(k) = Right(xh(k), Len(xh(k)) - 1)
Next k
With ThisWorkbook.Worksheets("Sheet3")
.UsedRange.Offset(1, 0).ClearContents
.Columns(1).NumberFormat = "@"
.[A2].Resize(xh.Count, 1) = Application.Transpose(xh.keys)
.[B2].Resize(xh.Count, 1) = Application.Transpose(xh.items)
End With
End Sub

复制代码

wangwei819 · 发表于 2018-10-14 21:48

chxw68 发表于 2018-10-12 10:00
详见附件。

数据量大的真实数据.zip (533.88 KB, 下载次数: 7)

数据量大的真实数据会报错，求助大神

wangwei819 · 发表于 2018-10-14 21:49

本帖最后由 wangwei819 于 2018-10-14 21:51 编辑

wdx223 发表于 2018-10-13 08:45

数据量大的真实数据.zip (533.88 KB, 下载次数: 3)
数据量大的真实数据，统计出来会有问题

ps：看上去课程名称好像不太对

chxw68 · 发表于 2018-10-15 09:06

修改好了。

wdx223 · 发表于 2018-10-15 09:19

wangwei819 发表于 2018-10-14 21:49
数据量大的真实数据，统计出来会有问题

ps：看上去课程名称好像不太对

Sub test2()
Dim kc, data, i&, j&, xh, k
data = ThisWorkbook.Worksheets("Sheet2").UsedRange
Set kc = CreateObject("Scripting.Dictionary")
For i = 2 To UBound(data)
For j = 1 To UBound(data, 2)
If data(1, j) <> "" And data(i, j) <> "" Then
kc(data(1, j) & "") = kc(data(1, j) & "") & "," & data(i, j)
End If
Next j
Next i
data = ThisWorkbook.Worksheets("Sheet1").UsedRange
Set xh = CreateObject("Scripting.Dictionary")
For i = 2 To UBound(data)
If data(i, 2) <> "" And data(i, 1) <> "" Then
If Not xh.exists(data(i, 2) & "") Then xh(data(i, 2) & "") = kc(data(i, 1) & "")
If data(i, 4) >= 60 Then
xh(data(i, 2) & "") = Replace(xh(data(i, 2) & ""), "," & data(i, 3) & ",", ",")
End If
End If
Next i
For Each k In xh.keys
If xh(k) <> "" Then xh(k) = Right(xh(k), Len(xh(k)) - 1)
Next k
With ThisWorkbook.Worksheets("Sheet3")
.UsedRange.Offset(1, 0).ClearContents
.Columns(1).NumberFormat = "@"
.[A2].Resize(xh.Count, 1) = Application.Transpose(xh.keys)
.[B2].Resize(xh.Count, 1) = Application.Transpose(xh.items)
End With
End Sub

复制代码

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

[求助] 如何通过类型判断学生应修课程不及格

评分

评分

评分

评分

评分

评分