一元非线性f2.frm

这是一个有关概率中的回归分析算法,内有多种算法,欢迎大家使用.

        lblNum(I).Move lblNum(0).Left, lblNum(0).Top + H * I
    Next I
    lblD.Visible = False: lblF.Visible = False: lblS.Visible = False
    Line1.Visible = False
End Sub

'计算
Private Sub cmdCalculate_Click()
    Dim m As Integer, R2 As Double, RMax As Double
    ReDim b0(1 To 10), b1(1 To 10)              '*****
    m = UBound(x, 1)
    For I = 1 To m
        xx(I) = x(I): yy(I) = y(I)
    Next I
    Line1.Visible = True
    For I = 0 To 10                             '*****
        lblN(I).Visible = True: lblB0(I).Visible = True
        lblB1(I).Visible = True: lblR2(I).Visible = True
        lblNum(I).Visible = True: lblNum(I).Caption = I
    Next I
    lblNum(0).Caption = "引用号"
'*****
    lblN(1).Caption = "线性"
    lblN(2).Caption = "双曲线(1)": lblN(3).Caption = "双曲线(2)"
    lblN(4).Caption = "X对数": lblN(5).Caption = "Y对数"
    lblN(6).Caption = "双对数": lblN(7).Caption = "S型"
    lblN(8).Caption = "X平方根": lblN(9).Caption = "Y平方根"
    lblN(10).Caption = "双平方根"
    lblD.Visible = True: lblF.Visible = True: lblS.Visible = True
'*****
    LinR2 x, y, b0(1), b1(1), R2    '线性回归方程
    lblB0(1).Caption = b0(1): lblB1(1).Caption = b1(1): lblR2(1).Caption = R2
'*****
    For I = 1 To m
        If x(I) = 0 Then
            MsgBox "在自变量中有0，需先进行数据变换再使用本程序！"
            End
        End If
        x(I) = 1 / x(I)
    Next I
    LinR2 x, y, b0(2), b1(2), R2    '双曲线回归方程(1)
    lblB0(2).Caption = b0(2): lblB1(2).Caption = b1(2): lblR2(2).Caption = R2
'*****
    For I = 1 To m
        x(I) = xx(I)
        If x(I) = 0 Or y(I) = 0 Then
            MsgBox "在自变量或因变量中有0，需先进行数据变换再使用本程序！"
            End
        End If
        x(I) = 1 / x(I)
        y(I) = 1 / y(I)
    Next I
    LinR2 x, y, b0(3), b1(3), R2    '双曲线回归方程(2)
    lblB0(3).Caption = b0(3): lblB1(3).Caption = b1(3): lblR2(3).Caption = R2
'*****
    For I = 1 To m
        x(I) = xx(I): y(I) = yy(I)
        If x(I) <= 0 Then
            MsgBox "在自变量中有0或负数，需先进行数据变换再使用本程序！"
            End
        End If
        x(I) = Log(x(I))
    Next I
    LinR2 x, y, b0(4), b1(4), R2    'X对数回归方程
    lblB0(4).Caption = b0(4): lblB1(4).Caption = b1(4): lblR2(4).Caption = R2
'*****
    For I = 1 To m
        x(I) = xx(I): y(I) = yy(I)
        If y(I) <= 0 Then
            MsgBox "在因变量中有0或负数，需先进行数据变换再使用本程序！"
            End
        End If
        y(I) = Log(y(I))
    Next I
    LinR2 x, y, b0(5), b1(5), R2    'Y对数回归方程
    lblB0(5).Caption = b0(5): lblB1(5).Caption = b1(5): lblR2(5).Caption = R2
'*****
    For I = 1 To m
        x(I) = xx(I): y(I) = yy(I)
        If x(I) <= 0 Or y(I) <= 0 Then
            MsgBox "在自变量或因变量中有0或负数，需先进行数据变换再使用本程序！"
            End
        End If
        x(I) = Log(x(I)) / Log(10)
        y(I) = Log(y(I)) / Log(10)
    Next I
    LinR2 x, y, b0(6), b1(6), R2     '双对数回归方程
    lblB0(6).Caption = b0(6): lblB1(6).Caption = b1(6): lblR2(6).Caption = R2
'*****
    For I = 1 To m
        x(I) = xx(I): y(I) = yy(I)
        If y(I) = 0 Then
            MsgBox "在因变量中有0，需先进行数据变换再使用本程序！"
            End
        End If
        x(I) = Exp(-x(I))
        y(I) = 1 / y(I)
    Next I
    LinR2 x, y, b0(7), b1(7), R2     'S型回归方程
    lblB0(7).Caption = b0(7): lblB1(7).Caption = b1(7): lblR2(7).Caption = R2
'*****
    For I = 1 To m
        x(I) = xx(I): y(I) = yy(I)
        If x(I) < 0 Then
            MsgBox "在自变量中有负数，需先进行数据变换再使用本程序！"
            End
        End If
        x(I) = Sqr(x(I))
    Next I
    LinR2 x, y, b0(8), b1(8), R2     'X平方根回归方程
    lblB0(8).Caption = b0(8): lblB1(8).Caption = b1(8): lblR2(8).Caption = R2
'*****
    For I = 1 To m
        x(I) = xx(I): y(I) = yy(I)
        If y(I) < 0 Then
            MsgBox "在因变量中有负数，需先进行数据变换再使用本程序！"
            End
        End If
        y(I) = Sqr(y(I))
    Next I
    LinR2 x, y, b0(9), b1(9), R2     'Y平方根回归方程
    lblB0(9).Caption = b0(9): lblB1(9).Caption = b1(9): lblR2(9).Caption = R2
'*****
    For I = 1 To m
        x(I) = xx(I): y(I) = yy(I)
        If x(I) < 0 Or y(I) < 0 Then
            MsgBox "在自变量或因变量中有负数，需先进行数据变换再使用本程序！"
            End
        End If
        x(I) = Sqr(x(I)): y(I) = Sqr(y(I))
    Next I
    LinR2 x, y, b0(10), b1(10), R2     '双平方根回归方程
    lblB0(10).Caption = b0(10): lblB1(10).Caption = b1(10): lblR2(10).Caption = R2
'*****
    RMax = Val(lblR2(1)): IMax = 1
'根据拟合指数确定最佳回归方程
'*****
    For I = 1 To 10
        If Val(lblR2(I)) > RMax Then
            RMax = Val(lblR2(I)): IMax = I
        End If
    Next I
'显示最佳回归方程
    Select Case IMax
        Case 1                                          '*****
            lblS = "线性"
            lblF = "Y = " & lblB0(1) & " + " & lblB1(1) & " * X"
        Case 2                                          '*****
            lblS = "双曲线(1)"
            lblF = "Y = " & lblB0(2) & " + " & lblB1(2) & " / X"
        Case 3                                          '*****
            lblS = "双曲线(2)"
            lblF = "1 / Y = " & lblB0(3) & " + " & lblB1(3) & " / X"
        Case 4                                          '*****
            lblS = "X对数"
            lblF = "Y = " & lblB0(4) & " + " & lblB1(4) & " * Ln(X)"
        Case 5                                          '*****
            lblS = "Y对数"
            lblF = "Ln(Y) = " & lblB0(5) & " + " & lblB1(5) & " * X"
        Case 6                                          '*****
            lblS = "双对数"
            lblF = "Ln(Y) = " & lblB0(6) & " + " & lblB1(6) & " * Ln(X)"
        Case 7                                          '*****
            lblS = "S型"
            lblF = "Y = 1 /(" & lblB0(7) & " + " & lblB1(7) & _
            " * EXP(-X))"
        Case 8                                          '*****
            lblS = "X平方根"
            lblF = "Y =" & lblB0(8) & " + " & lblB1(8) & " * Sqr(X)"
        Case 9                                          '*****
            lblS = "Y平方根"
            lblF = "Sqr(Y)=" & lblB0(9) & " + " & lblB1(9) & " * X"
        Case 10                                         '*****
            lblS = "双平方根"
            lblF = "Sqr(Y)=" & lblB0(10) & " + " & lblB1(10) & " * Sqr(X)"
    End Select
'恢复原始数据
    For I = 1 To m
        x(I) = xx(I): y(I) = yy(I)
    Next I
    cmdCalculate.Visible = False
    cmdContinue.Visible = True: cmdSelect.Visible = True
End Sub

Private Sub cmdSelect_Click()
    On Error GoTo LL
    lblD.Caption = "自选回归方程"
    IMax = InputBox("提供回归方程引用号", "自选", 1, 7000, 7000)
'显示最佳回归方程
    Select Case IMax
        Case 1                                          '*****
            lblS = "线性"
            lblF = "Y = " & lblB0(1) & " + " & lblB1(1) & " * X"
        Case 2                                          '*****
            lblS = "双曲线(1)"
            lblF = "Y = " & lblB0(2) & " + " & lblB1(2) & " / X"
        Case 3                                          '*****
            lblS = "双曲线(2)"
            lblF = "1 / Y = " & lblB0(3) & " + " & lblB1(3) & " / X"
        Case 4                                          '*****
            lblS = "X对数"
            lblF = "Y = " & lblB0(4) & " + " & lblB1(4) & " * Ln(X)"
        Case 5                                          '*****
            lblS = "Y对数"
            lblF = "Ln(Y) = " & lblB0(5) & " + " & lblB1(5) & " * X"
        Case 6                                          '*****
            lblS = "双对数"
            lblF = "Ln(Y) = " & lblB0(6) & " + " & lblB1(6) & " * Ln(X)"
        Case 7                                          '*****
            lblS = "S型"
            lblF = "Y = 1 /(" & lblB0(7) & " + " & lblB1(7) & _
            " * EXP(-X))"
        Case 8                                          '*****
            lblS = "X平方根"
            lblF = "Y =" & lblB0(8) & " + " & lblB1(8) & " * Sqr(X)"
        Case 9                                          '*****
            lblS = "Y平方根"
            lblF = "Sqr(Y)=" & lblB0(9) & " + " & lblB1(9) & " * X"
        Case 10                                         '*****
            lblS = "双平方根"
            lblF = "Sqr(Y)=" & lblB0(10) & " + " & lblB1(10) & " * Sqr(X)"
    End Select
LL:
'恢复原始数据
    For I = 1 To m
        x(I) = xx(I): y(I) = yy(I)
    Next I
    cmdCalculate.Visible = False
    cmdContinue.Visible = True
End Sub
'继续
Private Sub cmdContinue_Click()
    Unload Me
    frmContinue.Visible = True
End Sub

'退出
Private Sub cmdExit_Click()
    Unload Me
    frmFileName.Visible = True
End Sub