共有两个大问题需要解决:①如何按百分比提取需要补考学生名单;②如何把两次同科需要的学生改为只需补考一次即可。
第1个问题已经解决,充分利用Application.WorksheetFunction.Percentile(Range(Cells(2, 5), Cells(totalR, 5)), 1 - (50 + (i - 1) * 50) / totalR)就可以解决。
现在主要是想来解决第2个问题:
以第5学段文科及第6学段文科为例:
原表示意如下:其中图1为第5学段示意图,图2为第6学段示意图。由于不可避免的5、6学段中肯定会有重复的学生。所以现在需要做的就是如何把在第6学段中存在且在第5学段也有,并且具有相同科目需要补考的学生做出标志。
图1 图2
下面先把需要删掉的重复行做上标志:“重复”字样
Sub 按科合并重复项()
Dim i As Integer, j As Integer, k As Integer, totalR5 As Integer, totalR6 As Integer
Dim mycell As Range, myrange As Range
Worksheets("第5学段文科补考名单").Activate
totalR5 = Range("A65536").End(xlUp).Row
For i = 2 To totalR5
Worksheets("第5学段文科补考名单").Activate
Set mycell = Range(Cells(i, 2), Cells(i, 2))
Worksheets("第6学段文科补考名单").Activate
totalR6 = Range("A65536").End(xlUp).Row
For Each myrange In Range(Cells(2, 2), Cells(totalR6, 2))
If mycell.Value = myrange.Value Then
For j = 1 To 3
If (mycell.Offset(0, j).Value <> "" And myrange.Offset(0, j).Value = "") Or (mycell.Offset(0, j).Value <> "" And myrange.Offset(0, j).Value <> "") Then
myrange.Offset(0, j).Value = mycell.Offset(0, j).Value
mycell.Font.ColorIndex = 3
mycell.Offset(0, 4).Value = "重复"
If mycell.Offset(0, j).Value <> "" And myrange.Offset(0, j).Value <> "" Then
myrange.Offset(0, j).Value = mycell.Offset(0, j).Value
mycell.Font.ColorIndex = 3
mycell.Offset(0, 4).Value = "重复"
End If
End If
Next j
End If
Next myrange
Next i
Set mycell = Nothing
End Sub
此时效果图如下图所示:
下面需要做的是把带有重复标志的行删掉。
Sub 删除重复行()
Worksheets("第5学段文科补考名单").Activate
totalR5 = Range("A65536").End(xlUp).Row
For i = totalR5 To 2 Step -1
If Range(Cells(i, 6), Cells(i, 6)).Value = "重复" Then
Range(Cells(i, 6), Cells(i, 6)).EntireRow.Delete
End If
Next i
End Sub
此时效果图如下图所示:
然后把此表余下部分复制到第6学段中即可。
![菊子曰](https://i-blog.csdnimg.cn/blog_migrate/bcfc021cd9686f287c7a9998494cbb28.png)