form1.frm

线性回归

VERSION 5.00
Begin VB.Form Form1 
   Caption         =   "Form1"
   ClientHeight    =   3870
   ClientLeft      =   60
   ClientTop       =   345
   ClientWidth     =   5640
   LinkTopic       =   "Form1"
   ScaleHeight     =   3870
   ScaleWidth      =   5640
   StartUpPosition =   3  '窗口缺省
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Public Sub arrMatT(mat() As Double, matT() As Double) '----矩阵翻转-----
Dim x, y, i, j As Integer
x = UBound(mat, 1)
y = UBound(mat, 2)
ReDim matT(y, x)
For i = 1 To x
For j = 1 To y
matT(j, i) = mat(i, j)
Next
Next
End Sub
Public Sub arrMatM(mat1() As Double, mat2() As Double, matM() As Double) '----2维矩阵相乘----
Dim x1, x2, y1, y2 As Integer
Dim i, j, k As Integer
x1 = UBound(mat1, 1)
y1 = UBound(mat1, 2)
x2 = UBound(mat2, 1)
y2 = UBound(mat2, 2)
If y1 <> x2 Then
MsgBox "不能相乘"
Exit Sub
End If
ReDim matM(x1, y2)
For i = 1 To x1
For j = 1 To y2
For k = 1 To y1
matM(i, j) = matM(i, j) + mat1(i, k) * mat2(k, j)
Next
Next
Next
End Sub
Public Sub jzqn(qa() As Double, na() As Double) '--------矩阵求逆---------
Dim a()
n = UBound(qa, 1)
ReDim na(n, n)
ReDim a(n, 2 * n)
  For i = 1 To n
    For j = 1 To n
      a(i, j) = qa(i, j)
    Next j
  Next i
For i = 1 To n
 For j = n + 1 To 2 * n
  If j - i = n Then
  a(i, j) = 1
  Else
  a(i, j) = 0
  End If
  Next j
  Next i
 For i = 1 To n
  If a(i, i) = 0 Then
    For q = i To n
    If a(q, i) <> 0 Then
       For w = i To 2 * n
         zj = a(i, w)
         a(i, w) = a(q, w)
         a(q, w) = zj
       Next w
       Exit For
    End If
    Next q
    If q > n Then MsgBox "此矩阵不可逆": Exit Sub
  End If
  For k = 2 * n To i Step -1
  a(i, k) = a(i, k) / a(i, i)
  Next k
  For j = i + 1 To n
  If a(j, i) <> 0 Then
     For k = 2 * n To i Step -1
    a(j, k) = a(j, k) / a(j, i) - a(i, k)
    Next k
    End If
 Next j
Next i
For i = n To 1 Step -1
  If a(i, i) = 0 Then
    For q = i - 1 To 1 Step -1
    If a(q, i) <> 0 Then
       For w = i To 2 * n
         zj = a(i, w)
         a(i, w) = a(q, w)
         a(q, w) = zj
       Next w
       Exit For
    End If
    Next q
  End If
  For k = 2 * n To i Step -1
  a(i, k) = a(i, k) / a(i, i)
  Next k
  For j = i - 1 To 1 Step -1
  If a(j, i) <> 0 Then
  xxx = a(j, i)
  For k = 2 * n To 1 Step -1
    a(j, k) = a(j, k) / xxx - a(i, k)
    Next k
    End If
 Next j
Next i
For i = 1 To n
 For j = 1 To n
   na(i, j) = a(i, j + n)
Next j
Next i
End Sub
'----------------------过程结束---------
Public Sub arrMatB(matY() As Double, matX() As Double, matb() As Double) '-----求系数B-------
Dim x1, y1, y, b As Integer
Dim matT() As Double '翻转矩阵
Dim matM() As Double '翻转矩阵与原来矩阵相乘
Dim matInv() As Double 'matM矩阵求逆
Dim temp() As Double 'matInv*matT
x1 = UBound(matX, 1)
y1 = UBound(matX, 2)
y = UBound(matY, 1)
b = x1
ReDim matb(b, 1)
Call arrMatT(matX, matT)
Call arrMatM(matT, matX, matM)
Call jzqn(matM, matInv)
Call arrMatM(matInv, matT, temp)
Call arrMatM(temp, matY, matb)



End Sub



Private Sub Form_Load() '------例子-----
Show
Dim a(2, 2) As Double
Dim matb() As Double
Dim matY(2, 1) As Double

a(1, 1) = 2
a(2, 2) = 2
a(1, 2) = 1
 a(2, 1) = 3
 matY(1, 1) = 3
 matY(2, 1) = 5

Call arrMatB(matY, a, matb)

For i = 1 To 2
Print matb(i, 1)
Next

End Sub