VBA程序源代码
- 格式：rtf
- 大小：43.31 KB
- 文档页数：8
VBA程序源代码
'###########################################
'# 北师大实验中学----研究性学习 #
'# 研究成绩波动规律的拟合程序 #
'# Module1主模块部分 #
'# 李博昱编译 #
'# 2007年5月－6月 #
'###########################################
'加 ' 的文字均为本程序的注释
（1）常量的设定
'1、常量e，表示自然对数底
'2、num，表示参与拟合的考试次数，这里取前7次考试成绩
'3、cen，三角拟合时，角度所乘系数中心值，详见原理介绍
'4、le，三角拟合精度，详见原理介绍
'5、un，三角拟合角度系数的偏离值，详见原理介绍
'6、StuNumber，学生容量，这里取2008届高二年级组学生总人数
Public Const e = 2.71
Public Const num = 7
Public Const le = 100
Public Const cen = 1
Public Const un = 0.99
Public Const StuNumber = 534
（2）辅助函数的介绍
'本部分共计运用辅助函数5个，
'每个辅助函数的功能均在其上方注释，
'函数内部的运算原理见代码区内部
'1、StuMark，获取学生成绩
'参变量：
'StuNum，整型变量，表示学生代号
'ExamNum：整型变量，表示考试代号，取值为1－7
'SubNum：整型变量，表示科目代号，取值为1－5
Public Function StuMark(StuNum As Integer, ExamNum As Integer, SubNum As Integer)
As Double
'Select结构对ExamNum进行讨论
Select Case ExamNum
Case 1
StuMark = Sheet1.Cells(StuNum + 1, SubNum + 8)
Case 2
StuMark = Sheet2.Cells(StuNum + 1, SubNum + 8)
Case 3
StuMark = Sheet3.Cells(StuNum + 1, SubNum + 8)
Case 4 StuMark = Sheet4.Cells(StuNum + 1, SubNum + 8)
Case 5
StuMark = Sheet5.Cells(StuNum + 1, SubNum + 8)
Case 6
StuMark = Sheet6.Cells(StuNum + 1, SubNum + 8)
Case 7
StuMark = Sheet7.Cells(StuNum + 1, SubNum + 8)
Case 8
StuMark = Sheet8.Cells(StuNum + 1, SubNum + 8)
End Select
End Function
'2、FitFunc，代表拟合函数的形式，由此和真实值进行线性拟合，详见原理部分
'参变量：
'k：角度系数值，详见原理部分
'j：学生代号
Function FitFunc(k, j) As Double
Dim X
X = Sheet10.Cells(3, j) / k
FitFunc = Tan(X)
End Function
'3、FindFit，线性拟合函数
'变量
'xx：x的离均差平方和
'xy：x，y的离均差的成绩之和
'avx，x的均值
'avy，y的均值
'StuNum，整型变量，同前
'SubNum，同前
Function FindFit(xx, xy, avx, avy, StuNum As Integer, SubNum As Integer)
Dim b
b = xy / xx '由此式确定线性拟合中x的一次项系数
Sheet12.Cells(StuNum + 1, 2 * SubNum) = b
Sheet12.Cells(StuNum + 1, 2 * SubNum + 1) = avy - b * abx
FindFit = 0
End Function
'4、TestMod检验模型
Function TestMod(StuNum As Integer, SubNum As Integer, k, avy)
Dim a, b
a = Sheet12.Cells(StuNum + 1, 2 * SubNum + 1)
b = Sheet12.Cells(StuNum + 1, 2 * SubNum)
Sheet13.Cells(StuNum + 1, 2 * SubNum) = b * FitFunc(k, 8) + a + avy Sheet13.Cells(StuNum + 1, 2 * SubNum + 1) = Sheet8.Cells(StuNum + 1, SubNum + 8)
TestMod = 0
End Function
'5、AppFunc 应用模型
'通过已建立的模型，计算指定次考试中的预期值
Function AppFunc(StuNum As Integer, SubNum As Integer, ExamNum As Integer, k, avy)
Dim a, b
Dim M
M = StuMark(StuNum, ExamNum, SubNum)
If M = 0 Then
AppFunc = 0
Else
a = Sheet12.Cells(StuNum + 1, 2 * SubNum + 1)
b = Sheet12.Cells(StuNum + 1, 2 * SubNum)
AppFunc = Abs((M - (b * FitFunc(k, ExamNum) + a + avy)) / M)
End If
End Function
（3）Module1的主程序CalR
'功能：
'计算线性拟合时，角度系数的最佳值
'这部分程序时本次研究性学习的核心部分
'具体运算过程见其中注释
Sub CalR()
'变量定义区
Dim i, k, avy, avx, xy, xx, yy, avd
Dim j As Integer
Dim mm, mn
'几个数组的定义
Dim Y(1 To num)
Dim X(1 To num)
Dim DY(1 To num)
Dim stNum As Integer
Dim subN As Integer
Dim g(-le To le)
Dim Q
'拟定初始值
subN = 1
'开始循环结构
'共计循环近700万次
'总共用时10-20分钟
For subN = 1 To 5
For stNum = 1 To StuNumber avy = 0
avd = 0
'子循环结
'计算学生平均相对成绩
For j = 1 To num
Y(j) = StuMark(stNum, j, subN)
avy = avy + Y(j) / num
Next j
'子循环结
'计算学生平均相对成绩离均差
For j = 1 To num
DY(j) = Y(j) - avy
avd = avd + DY(j) / num
Next j
'开始循环，寻找角度系数的最佳取值
For i = -le To le
avx = 0
xx = 0
yy = 0
xy = 0
k = cen + i / (le / un) 'k即使角度系数
For j = 1 To num
X(j) = FitFunc(k, j)
avx = avx + X(j) / num
Next j
'计算线性相关系数
For j = 1 To num
xy = xy + (X(j) - avx) * (DY(j) - avd)
xx = xx + (X(j) - avx) ^ 2
yy = yy + (DY(j) - avd) ^ 2
Next j
g(i) = Abs(xy / (Sqr(xx) * Sqr(yy)))
If i = -le Then
mm = g(-le)
mn = k
Else
If g(i) > mm Then
mm = g(i)
mn = k
End If
End If
'判定线性相关系数取极大值时角度系数的值
Next i
Sheet11.Cells(stNum + 1, 2 * subN) = mm
