VBA实例：高考分数投档指数分析（模块1.函数部分）

Function 返回学校记录数()
Dim I%
Dim rng As range
返回学校记录数 = 0
I = 0
For Each rng In ThisWorkbook.Worksheets("备选院校").range("C5:C200")
If Trim(rng) <> "" Then
I = I + 1
End If
Next rng
返回学校记录数 = I
End Function

Function 返回学校代码(code_s As Variant, name_s As Variant)
Dim I%
Dim rng As range
返回学校代码 = 0
If Trim(code_s) <> "" Then
For Each rng In ThisWorkbook.Worksheets("备选院校").range("C5:C200")
If Trim(rng) = Trim(code_s) And Trim(rng(1, 2)) = Trim(name_s) Then
返回学校代码 = 1
Exit Function
End If
Next rng
End If
End Function

Function 返回排除代码(code_s As Variant, name_s As Variant)
Dim I%
Dim rng As range
返回排除代码 = 0
If Trim(code_s) <> "" Then
For Each rng In ThisWorkbook.Worksheets("排除院校列表").range("B2:B500")
If Trim(rng) = Trim(code_s) And Trim(rng(1, 2)) = Trim(name_s) Then
返回排除代码 = 1
Exit Function
End If
Next rng
End If
End Function

Function 返回重点学校(code_s As Variant)
Dim I%
Dim rng As range
返回重点学校 = ""
If Trim(code_s) <> "" Then
For Each rng In ThisWorkbook.Worksheets("重点大学明细").range("B2:B200")
If rng = code_s Then
返回重点学校 = Trim(rng(1, 4)) & "-" & rng(1, 5)
Exit Function
End If
Next rng
End If
End Function

Function 返回学校评级(code_s As Variant)
Dim I%
Dim rng As range
返回学校评级 = ""
If Trim(code_s) <> "" Then
For Each rng In ThisWorkbook.Worksheets("学校评级").range("B2:B200")
If rng = code_s Then
返回学校评级 = Trim(rng(1, 5)) & "-" & rng(1, 3) '& "-" & rng(1, 6)
Exit Function
End If
Next rng
End If
End Function

Function 返回院校投档数据(ps As Variant, years As Variant, kl As Variant)
Dim I%
Dim rng As range
返回院校投档数据 = 0
For Each rng In ThisWorkbook.Worksheets("院校投档分数线").range("B2", ThisWorkbook.Worksheets("院校投档分数线").[B2].End(xlDown))
If rng = years And InStr(rng(1, 4), Mid(kl, 1, 1)) > 0 And rng(1, 2) = ps Then
返回院校投档数据 = 1
Exit Function
End If
Next rng
End Function

Functi
60dc
on 查投档线(ps As Variant, years As Variant, kl As Variant)
Dim I%
Dim rng As range
查投档线 = 0
For Each rng In ThisWorkbook.Worksheets("投档分数线").range("A2:A20")
If rng = years And InStr(rng(1, 2), Mid(kl, 1, 1)) > 0 Then
If ps = "本科一批院校A段" Then
查投档线 = rng(1, 4)
End If
If ps = "本科二批院校A段" Then
查投档线 = rng(1, 6)
End If
Exit Function
End If
Next rng
End Function

Function 查同排名分数(pm As Variant, years As Variant, kl As Variant)
Dim rng As range
查同排名分数 = ""
If pm = 0 Or pm = "" Then
Exit Function
End If
For Each rng In ThisWorkbook.Worksheets("一分一段表").range("A2", ThisWorkbook.Worksheets("一分一段表").[A2].End(xlDown))
If rng = years Then
If rng(1, 5) >= pm And InStr(rng(1, 2), Mid(kl, 1, 1)) > 0 Then
查同排名分数 = rng(1, 3)
Exit Function
End If
End If
Next rng
End Function

Function 查排名(fs As Variant, years As Variant, kl As Variant)
Dim fs0%
Dim rng As range
查排名 = "-"
If fs = 0 Or fs = "" Then
Exit Function
End If
fs0 = fs
For Each rng In ThisWorkbook.Worksheets("一分一段表").range("C2", ThisWorkbook.Worksheets("一分一段表").[C2].End(xlDown))
If rng = fs0 Then
If rng(1, -1) = years And InStr(rng(1, 0), Mid(kl, 1, 1)) > 0 Then
查排名 = rng(1, 3)
Exit Function
End If
End If
Next rng
End Function

Function 查省排名(fs As Variant, years As Variant, kl As Variant)
Dim I%, fs0%
Dim rng As range
查省排名 = 0
If fs = 0 Or fs = "" Then
Exit Function
End If
fs0 = fs
For I = 1 To 100
For Each rng In ThisWorkbook.Worksheets("一分一段表").range("C2", ThisWorkbook.Worksheets("一分一段表").[C2].End(xlDown))
If rng = fs0 Then
If rng(1, -1) = years And InStr(rng(1, 0), Mid(kl, 1, 1)) > 0 Then
查省排名 = rng(1, 3)
Exit Function
End If
End If
Next rng
If 查省排名 = 0 Then
fs0 = fs - I
End If
Next
End Function

Function 返回历史数据(row_s As Variant) '
Dim I%
Dim rng As range
返回历史数据 = 0
I = 0
For Each rng In ThisWorkbook.Worksheets("备选院校").range("C5:C500")
If rng.Row = row_s Then
If Trim(rng(1, 7)) <> "" And rng(1, 7) > 0 Then
I = I + 1
End If
If Trim(rng(1, 11)) <> "" And rng(1, 11) > 0 Then
I = I + 1
End If
If Trim(rng(1, 15)) <> "" And rng(1, 15) > 0 Then
I = I + 1
End If
Exit For
End If
Next rng
返回历史数据 = I
End Function