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

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

Function 查投档线(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