VBA实例：高考分数投档指数分析（备选院校页）
作者：互联网
'当前页：ThisWorkbook.Worksheets("备选院校")
Sub 清除数据总()
If ThisWorkbook.Worksheets("排除院校列表").range("B2") <> "" Then
Dim YN As Integer
YN = MsgBox(prompt:="重要提示：排除院校列表尚存记录，这些院校记录将不会被本次检索出来，如该数据不是正确记录，请及时删除！", Title:="提示！")
End If
range("A5:AG500").ClearContents
Call 初始数据
End Sub
Sub 清除数据()
range("O2") = ""
range("Q2") = ""
range("J2") = ""
range("AC2") = ""
range("AE2") = ""
range("AG2") = ""
End Sub
Sub 排除院校()
Dim I%
Dim rngs As range, cell As range
I = Selection.Row
If I > 4 Then
Selection.EntireRow.Select
Intersect(Selection, range("C:D")).Select
Set rngs = Selection
Set cell = ThisWorkbook.Worksheets("排除院校列表").[B500].End(xlUp)(2, 1)
rngs.Copy cell
Selection.EntireRow.Select
Selection.ClearContents
[A1].Select
[AA2] = 返回学校记录数()
Call 记录排序
End If
End Sub
Sub 初始数据()
[H3] = [B2] - 1
[L3] = [B2] - 2
[P3] = [B2] - 3
[j2] = 查省排名([H2], [B2], [L2])
[o2] = 查投档线([D2], [B2], [L2])
[Q2] = [H2] - [o2]
[ac2] = 查同排名分数([j2], [H3], [L2])
[ae2] = 查同排名分数([j2], [L3], [L2])
[ag2] = 查同排名分数([j2], [P3], [L2])
End Sub
Sub 搜索学校()
Call 清除数据
Call 初始数据
Call 搜上1年
MsgBox "搜索完毕！"
End Sub
Sub 补充数据()
range("I5:K500").ClearContents
range("M5:O500").ClearContents
range("Q5:S500").ClearContents
Call 填资料
Call 填数据(1)
Call 填数据(2)
Call 填数据(3)
If [B2] < "2020" Then
Call 填数据(4)
End If
Call 记录排序
MsgBox "补充数据完毕！"
End Sub
Sub 搜上1年()
Dim I%, J%
Dim rng As range, rng1 As range, rng2 As range
I = 返回学校记录数() + 1
For Each rng1 In ThisWorkbook.Worksheets("院校投档分数线").range("B2", ThisWorkbook.Worksheets("院校投档分数线").[B2].End(xlDown))
If rng1 = [H3] And InStr(rng1(1, 4), Mid([L2], 1, 1)) > 0 And rng1(1, 2) = [D2] Then '年，科类，
If 返回学校代码(Trim(rng1(1, 3)), Trim(rng1(1, 5))) = 0 And 返回排除代码(Trim(rng1(1, 3)), Trim(rng1(1, 5))) = 0 Then
If rng1(1, 7) >= [j2] + [U2] And rng1(1, 7) <= [j2] + [V2] Then
range("C5")(I, 1) = rng1(1, 3)
range("C5")(I, 2) = rng1(1, 5)
range("C5")(I, 7) = Int(rng1(1, 6))
range("C5")(I, 8) = rng1(1, 8)
range("C5")(I, 9) = rng1(1, 7)
range("C5")(I, -1) = rng1(1, 2)
I = I + 1
Else
If rng1(1, 8) <= [Q2] + [X2] And rng1(1, 8) >= [Q2] + [y2] Then
range("C5")(I, 1) = rng1(1, 3)
range("C5")(I, 2) = rng1(1, 5)
range("C5")(I, 7) = Int(rng1(1, 6))
range("C5")(I, 8) = rng1(1, 8)
range("C5")(I, 9) = rng1(1, 7)
range("C5")(I, -1) = rng1(1, 2)
I = I + 1
End If
End If
Else
range("C5")(I, 2) = rng1(1, 5)
range("C5")(I, 7) = Int(rng1(1, 6))
range("C5")(I, 8) = rng1(1, 8)
End If
End If
End If
Else
range("C5")(I, 2) = rng1(1, 5)
range("C5")(I, 7) = Int(rng1(1, 6))
range("C5")(I, 8) = rng1(1, 8)
range("C5")(I, 9) = rng1(1, 7)
[AA2] = I - 1
End If
Next rng1
range("C5")(I, 2) = ""
range("C5")(I, 7) = ""
range("C5")(I, 8) = ""
range("C5")(I, 9) = ""
Call 搜上2年(I)
End Sub
Sub 搜上2年(row_s As Variant)
I = row_s
For Each rng1 In ThisWorkbook.Worksheets("院校投档分数线").range("B2", ThisWorkbook.Worksheets("院校投档分数线").[B2].End(xlDown))
If rng1 = [L3] And InStr(rng1(1, 4), Mid([L2], 1, 1)) > 0 And rng1(1, 2) = [D2] Then
If 返回学校代码(Trim(rng1(1, 3)), Trim(rng1(1, 5))) = 0 And 返回排除代码(Trim(rng1(1, 3)), Trim(rng1(1, 5))) = 0 Then
If rng1(1, 7) >= [j2] + [U2] And rng1(1, 7) <= [j2] + [V2] Then
range("C5")(I, 1) = rng1(1, 3)
range("C5")(I, 2) = rng1(1, 5)
range("C5")(I, 7 + 4) = Int(rng1(1, 6))
range("C5")(I, 8 + 4) = rng1(1, 8)
range("C5")(I, 9 + 4) = rng1(1, 7)
range("C5")(I, -1) = rng1(1, 2)
I = I + 1
Else
If rng1(1, 8) <= [Q2] + [X2] And rng1(1, 8) >= [Q2] + [y2] Then
range("C5")(I, 1) = rng1(1, 3)
range("C5")(I, 2) = rng1(1, 5)
range("C5")(I, 7 + 4) = Int(rng1(1, 6))
range("C5")(I, 8 + 4) = rng1(1, 8)
range("C5")(I, 9 + 4) = rng1(1, 7)
range("C5")(I, -1) = rng1(1, 2)
I = I + 1
End If
End If
End If
Else
range("C5")(I, 2) = rng1(1, 5)
range("C5")(I, 7 + 4) = Int(rng1(1, 6))
range("C5")(I, 8 + 4) = rng1(1, 8)
range("C5")(I, 9 + 4) = rng1(1, 7)
[AA2] = I - 1
End If
Next rng1
range("C5")(I, 2) = ""
range("C5")(I, 7 + 4) = ""
range("C5")(I, 8 + 4) = ""
range("C5")(I, 9 + 4) = ""
Call 搜上3年(I)
End Sub
Sub 搜上3年(row_s As Variant)
Dim I%, J%
Dim rng As range, rng1 As range, rng2 As range
I = row_s
For Each rng1 In ThisWorkbook.Worksheets("院校投档分数线").range("B2", ThisWorkbook.Worksheets("院校投档分数线").[B2].End(xlDown))
If rng1 = [P3] And InStr(rng1(1, 4), Mid([L2], 1, 1)) > 0 And rng1(1, 2) = [D2] Then
If 返回学校代码(Trim(rng1(1, 3)), Trim(rng1(1, 5))) = 0 And 返回排除代码(Trim(rng1(1, 3)), Trim(rng1(1, 5))) = 0 Then
If rng1(1, 7) >= [j2] + [U2] And rng1(1, 7) <= [j2] + [V2] Then
range("C5")(I, 1) = rng1(1, 3)
range("C5")(I, 2) = rng1(1, 5)
range("C5")(I, 7 + 8) = Int(rng1(1, 6))
range("C5")(I, 8 + 8) = rng1(1, 8)
range("C5")(I, 9 + 8) = rng1(1, 7)
range("C5")(I, -1) = rng1(1, 2)
I = I + 1
Else
If rng1(1, 8) <= [Q2] + [X2] And rng1(1, 8) >= [Q2] + [y2] Then
range("C5")(I, 1) = rng1(1, 3)
range("C5")(I, 2) = rng1(1, 5)
range("C5")(I, 7 + 8) = Int(rng1(1, 6))
range("C5")(I, 8 + 8) = rng1(1, 8)
range("C5")(I, 9 + 8) = rng1(1, 7)
range("C5")(I, -1) = rng1(1, 2)
I = I + 1
End If
End If
End If
Else
range("C5")(I, 2) = rng1(1, 5)
range("C5")(I, 7 + 8) = Int(rng1(1, 6))
range("C5")(I, 8 + 8) = rng1(1, 8)
range("C5")(I, 9 + 8) = rng1(1, 7)
[AA2] = I - 1
End If
Next rng1
range("C5")(I, 2) = ""
range("C5")(I, 7 + 8) = ""
range("C5")(I, 8 + 8) = ""
range("C5")(I, 9 + 8) = ""
End Sub
Sub 填资料()
Call 初始数据
Dim rng As range, rng1 As range
For Each rng In ThisWorkbook.Worksheets("备选院校").range("C5", ThisWorkbook.Worksheets("备选院校").[C5].End(xlDown))
If rng(1, 2) = "" Then
For Each rng1 In ThisWorkbook.Worksheets("院校投档分数线").range("D2", ThisWorkbook.Worksheets("院校投档分数线").[D2].End(xlDown))
If rng = rng1 And [D2] = rng1(1, 0) And InStr(rng1(1, 2), Mid([L2], 1, 1)) > 0 Then
rng(1, 2) = rng1(1, 3)
Exit For
End If
Next rng1
End If
rng(1, -1) = [D2]
rng(1, 0) = 返回重点学校(rng)
If rng(1, 0) = "" Then
rng(1, 0) = 返回学校评级(rng)
End If
If rng(1, 0) = "" Then
rng(1, 0) = " "
End If
Next rng
End Sub
Sub 填数据(type_s As Variant)
Dim rng As range, rng1 As range
For Each rng In ThisWorkbook.Worksheets("备选院校").range("C5", ThisWorkbook.Worksheets("备选院校").[C5].End(xlDown))
For Each rng1 In ThisWorkbook.Worksheets("院校投档分数线").range("D2", ThisWorkbook.Worksheets("院校投档分数线").[D2].End(xlDown))
If rng(1, 2) = rng1(1, 3) And Trim(rng) = Trim(rng1) And [D2] = rng1(1, 0) And InStr(rng1(1, 2), Mid([L2], 1, 1)) > 0 Then
If rng1(1, -1) = [H3] And type_s = 1 Then '本年
rng(1, 7) = Int(rng1(1, 4))
rng(1, 8) = Int(rng1(1, 6))
rng(1, 9) = Int(rng1(1, 5))
End If
If rng1(1, -1) = [L3] And type_s = 2 Then '去年
rng(1, 11) = Int(rng1(1, 4))
rng(1, 12) = Int(rng1(1, 6))
rng(1, 13) = Int(rng1(1, 5))
End If
If rng1(1, -1) = [P3] And type_s = 3 Then '前年
rng(1, 15) = Int(rng1(1, 4))
rng(1, 16) = Int(rng1(1, 6))
rng(1, 17) = Int(rng1(1, 5))
End If
If rng1(1, -1) = [B2] And type_s = 4 Then '当年
If ThisWorkbook.Worksheets("备选院校").[H2] >= Int(rng1(1, 4)) Then
rng(1, 19) = "投档" & Int(rng1(1, 4))
Else
rng(1, 19) = Int(rng1(1, 4))
End If
End If
If rng1(1, -1) = [B2] And type_s = 5 Then '当年
If ThisWorkbook.Worksheets("备选院校").[H2] >= Int(rng1(1, 4)) Then
rng(1, 19) = "投档" & Int(rng1(1, 4))
Else
rng(1, 19) = Int(rng1(1, 4))
End If
End If
End If
Next rng1
Next rng
End Sub
Sub 投档指数()
Dim I, J, xc, pm
Dim rng As range, rng1 As range
xc = [Q2]
pm = [j2]
For Each rng In ThisWorkbook.Worksheets("备选院校").range("C5", ThisWorkbook.Worksheets("备选院校").[C5].End(xlDown))
I = xc - (rng(1, 8) + rng(1, 12) + rng(1, 16)) / 返回历史数据(rng.Row) + 50
J = ((rng(1, 9) + rng(1, 13) + rng(1, 17)) / 返回历史数据(rng.Row) - pm) / 10 + 50
rng(1, 18) = (I + J) / 10
Next rng
If 返回院校投档数据([D2], [B2], [L2]) = 1 Then
Call 填数据(5)
End If
Call 投档排序
End Sub
标签：VBA,End,Sub,rng,range,C5,投档,rng1,备选 来源： https://blog.51cto.com/12815848/2527928