下面是小弟的程式碼 現在的問題是我在程式中有註解的那個列印矩陣的副程式裡所列印出來的m(i,j)跟我在程式開頭那個曲線方程式的注解下方的m(i,1),m(i,2),m(i,3)所列印出來的值不同,但我想兩者應該是相同的才是,因為我是先執行一個再載入另一個才執行的小弟實在不知道為什麼會如此 請高手幫幫忙~~~
Private Sub Command1_Click()
Dim Keyin As String, m() As Single, x() As Single, TreatStr As Single, k As Double, SepStr() As String
Keyin = InputBox("請輸入方陣,以分號"";""來分隔列元素,以空白來分隔欄元素。" _
& vbNewLine & "例如有一3×3的方陣:" & vbNewLine & "1 2 3 " & vbNewLine & _
"4 5 6 " & vbNewLine & "7 8 9 " & vbNewLine & "則輸入: 1 2 3;4 5 6;7 8 9 ", , "0 -1 3;1 0 -2;4 0 2")
If SepStrToMatrix(Keyin, ";", " ", m, SepStr) Then
'Debug.Print
Call MIMP(m, x)
Call PrintMatrix(x)
' Call PrintMatrix(m) '測試m是否為單位矩陣之用
Else
MsgBox "方陣輸入有誤,請重新輸入。"
End If
'曲線方程式
Dim pp() As Single, g() As Single, h() As Single, f() As Single, e() As Single, r As Double, o As Double, q As Single
ReDim g(1 To UBound(m))
ReDim h(1 To UBound(m))
ReDim f(1 To UBound(m))
ReDim e(1 To UBound(m))
ReDim pp(1 To UBound(m))
ReDim px(1 To UBound(m))
ReDim py(1 To UBound(m))
ReDim pz(1 To UBound(m))
Dim i As Long, ii As Long
For ii = 1 To UBound(SepStr)
For i = 1 To UBound(SepStr)
px(ii) = m(i, 1)
' Debug.Print px(ii)
Next
For i = 1 To UBound(SepStr)
py(ii) = m(i, 2)
Debug.Print py(ii)
Next
For i = 1 To UBound(SepStr)
pz(ii) = m(i, 3)
Next
Next
' f(r) = 3 * (h(r + 1) - h(r)) - (2 * g(r) + g(r + 1))
' e(r) = 2 * (h(r) - h(r + 1)) + g(r) + g(r + 1)
t = 1
'pp(r) = e(r) * t ^ 3 + f(r) * t ^ 2 + g(r) * t + h(r)
Next
'Next
'Next
' Next
End Sub
'IsNumeric會將含有逗號的數值判斷為true,所以If Not IsNumeric(temp) Or InStr(temp, ",") > 0 Then Exit Function
Public Function SepStrToMatrix(TreatStr As String, RowSepChr As String, ColSepChr As String, ReturnValue() As Single, SepStr() As String) As Boolean
If StrComp(RowSepChr, ColSepChr, vbBinaryCompare) = 0 Then MsgBox "列和欄的分隔字元不可相同"
Dim i As Long, j As Long, k As Long, temp As String, no As Long, row As Long
TreatStr = Trim(TreatStr)
Do
no = no + 1
ReDim Preserve SepStr(1 To no)
i = InStr(j + 1, TreatStr, RowSepChr, vbBinaryCompare)
If i <> 0 Then
SepStr(no) = Trim(Mid(TreatStr, j + 1, i - j - 1))
Else
SepStr(no) = Trim(Mid(TreatStr, j + 1))
End If
j = i
m = 1
Loop Until i = 0
row = no
ReDim ReturnValue(1 To row, 1 To 1)
For k = 1 To row
no = 0
Do
i = InStr(j + 1, SepStr(k), ColSepChr, vbBinaryCompare)
If i <> j + 1 Then
no = no + 1
If i <> 0 Or (i = 0 And j < Len(SepStr(k))) Then
If i <> 0 Then temp = Mid(SepStr(k), j + 1, i - j - 1) Else temp = Mid(SepStr(k), j + 1)
If Not IsNumeric(temp) Or InStr(temp, ",") > 0 Then Exit Function
If no > UBound(ReturnValue, 2) Then ReDim Preserve ReturnValue(1 To row, 1 To no)
ReturnValue(k, no) = temp
End If
End If
j = i
Loop Until i = 0
Next
SepStrToMatrix = True
End Function
'以下是列印矩陣的副程式
Public Sub PrintMatrix(m() As Single)
Dim i As Long, j As Long, Keyin As Single
Debug.Print
For i = 1 To UBound(m, 1)
For j = 1 To UBound(m, 2)
' i = i + 1
Debug.Print m(i, j);
Next
Debug.Print
Next
End Sub
Public Sub MIMP(m() As Single, ReturnValue() As Single)
Dim i As Long, j As Long, k As Long, n As Long
Dim r() As Long, c() As Long, row As Long, temp() As Single ', temp2() As Single '測試m是否為單位矩陣之用
Dim Pivot As Single, NoCompare As Boolean
row = UBound(m, 1)
If row <> UBound(m, 2) Then MsgBox "矩陣輸入有誤": Exit Sub
ReDim r(1 To row), c(1 To row), temp(1 To row), temp2(1 To row), ReturnValue(1 To row, 1 To row)
For i = 1 To row
ReturnValue(i, i) = 1
Next
For i = 1 To row
Pivot = 0
NoCompare = False
For j = 1 To row
For n = 1 To i - 1
NoCompare = (j = c(n))
If NoCompare Then Exit For
Next n
If Not NoCompare Then
For k = 1 To row
For n = 1 To i - 1
NoCompare = (k = r(n))
If NoCompare Then Exit For
Next n
If Not NoCompare Then
If Abs(m(k, j)) >= Pivot Then
Pivot = Abs(m(k, j))
r(i) = k: c(i) = j
End If
End If
Next k
End If
Next j
Pivot = m(r(i), c(i))
If Pivot <> 1 Then
For k = 1 To row
m(r(i), k) = m(r(i), k) / Pivot
ReturnValue(r(i), k) = ReturnValue(r(i), k) / Pivot
Next k
End If
For j = 1 To row
Pivot = m(j, c(i))
If j <> r(i) And Pivot <> 0 Then
For k = 1 To row
m(j, k) = m(j, k) - m(r(i), k) * Pivot
ReturnValue(j, k) = ReturnValue(j, k) - ReturnValue(r(i), k) * Pivot
Next
End If
Next j
Next i
For i = 1 To row - 1
If r(i) <> c(i) Then
For j = 1 To row
'測試m是否為單位矩陣之用
'temp2(j) = m(r(i), j)
'm(r(i), j) = m(c(i), j)
'm(c(i), j) = temp2(j)
temp(j) = ReturnValue(r(i), j)
ReturnValue(r(i), j) = ReturnValue(c(i), j)
ReturnValue(c(i), j) = temp(j)
Next
For j = i + 1 To row
If r(j) = c(i) Then r(j) = r(i): Exit For
Next
r(i) = c(i)
End If
Next
End Sub
Private Sub Command1_Click()
Dim Keyin As String, m() As Single, x() As Single, TreatStr As Single, k As Double, SepStr() As String
Keyin = InputBox("請輸入方陣,以分號"";""來分隔列元素,以空白來分隔欄元素。" _
& vbNewLine & "例如有一3×3的方陣:" & vbNewLine & "1 2 3 " & vbNewLine & _
"4 5 6 " & vbNewLine & "7 8 9 " & vbNewLine & "則輸入: 1 2 3;4 5 6;7 8 9 ", , "0 -1 3;1 0 -2;4 0 2")
If SepStrToMatrix(Keyin, ";", " ", m, SepStr) Then
'Debug.Print
Call MIMP(m, x)
Call PrintMatrix(x)
' Call PrintMatrix(m) '測試m是否為單位矩陣之用
Else
MsgBox "方陣輸入有誤,請重新輸入。"
End If
'曲線方程式
Dim pp() As Single, g() As Single, h() As Single, f() As Single, e() As Single, r As Double, o As Double, q As Single
ReDim g(1 To UBound(m))
ReDim h(1 To UBound(m))
ReDim f(1 To UBound(m))
ReDim e(1 To UBound(m))
ReDim pp(1 To UBound(m))
ReDim px(1 To UBound(m))
ReDim py(1 To UBound(m))
ReDim pz(1 To UBound(m))
Dim i As Long, ii As Long
For ii = 1 To UBound(SepStr)
For i = 1 To UBound(SepStr)
px(ii) = m(i, 1)
' Debug.Print px(ii)
Next
For i = 1 To UBound(SepStr)
py(ii) = m(i, 2)
Debug.Print py(ii)
Next
For i = 1 To UBound(SepStr)
pz(ii) = m(i, 3)
Next
Next
' f(r) = 3 * (h(r + 1) - h(r)) - (2 * g(r) + g(r + 1))
' e(r) = 2 * (h(r) - h(r + 1)) + g(r) + g(r + 1)
t = 1
'pp(r) = e(r) * t ^ 3 + f(r) * t ^ 2 + g(r) * t + h(r)
Next
'Next
'Next
' Next
End Sub
'IsNumeric會將含有逗號的數值判斷為true,所以If Not IsNumeric(temp) Or InStr(temp, ",") > 0 Then Exit Function
Public Function SepStrToMatrix(TreatStr As String, RowSepChr As String, ColSepChr As String, ReturnValue() As Single, SepStr() As String) As Boolean
If StrComp(RowSepChr, ColSepChr, vbBinaryCompare) = 0 Then MsgBox "列和欄的分隔字元不可相同"
Dim i As Long, j As Long, k As Long, temp As String, no As Long, row As Long
TreatStr = Trim(TreatStr)
Do
no = no + 1
ReDim Preserve SepStr(1 To no)
i = InStr(j + 1, TreatStr, RowSepChr, vbBinaryCompare)
If i <> 0 Then
SepStr(no) = Trim(Mid(TreatStr, j + 1, i - j - 1))
Else
SepStr(no) = Trim(Mid(TreatStr, j + 1))
End If
j = i
m = 1
Loop Until i = 0
row = no
ReDim ReturnValue(1 To row, 1 To 1)
For k = 1 To row
no = 0
Do
i = InStr(j + 1, SepStr(k), ColSepChr, vbBinaryCompare)
If i <> j + 1 Then
no = no + 1
If i <> 0 Or (i = 0 And j < Len(SepStr(k))) Then
If i <> 0 Then temp = Mid(SepStr(k), j + 1, i - j - 1) Else temp = Mid(SepStr(k), j + 1)
If Not IsNumeric(temp) Or InStr(temp, ",") > 0 Then Exit Function
If no > UBound(ReturnValue, 2) Then ReDim Preserve ReturnValue(1 To row, 1 To no)
ReturnValue(k, no) = temp
End If
End If
j = i
Loop Until i = 0
Next
SepStrToMatrix = True
End Function
'以下是列印矩陣的副程式
Public Sub PrintMatrix(m() As Single)
Dim i As Long, j As Long, Keyin As Single
Debug.Print
For i = 1 To UBound(m, 1)
For j = 1 To UBound(m, 2)
' i = i + 1
Debug.Print m(i, j);
Next
Debug.Print
Next
End Sub
Public Sub MIMP(m() As Single, ReturnValue() As Single)
Dim i As Long, j As Long, k As Long, n As Long
Dim r() As Long, c() As Long, row As Long, temp() As Single ', temp2() As Single '測試m是否為單位矩陣之用
Dim Pivot As Single, NoCompare As Boolean
row = UBound(m, 1)
If row <> UBound(m, 2) Then MsgBox "矩陣輸入有誤": Exit Sub
ReDim r(1 To row), c(1 To row), temp(1 To row), temp2(1 To row), ReturnValue(1 To row, 1 To row)
For i = 1 To row
ReturnValue(i, i) = 1
Next
For i = 1 To row
Pivot = 0
NoCompare = False
For j = 1 To row
For n = 1 To i - 1
NoCompare = (j = c(n))
If NoCompare Then Exit For
Next n
If Not NoCompare Then
For k = 1 To row
For n = 1 To i - 1
NoCompare = (k = r(n))
If NoCompare Then Exit For
Next n
If Not NoCompare Then
If Abs(m(k, j)) >= Pivot Then
Pivot = Abs(m(k, j))
r(i) = k: c(i) = j
End If
End If
Next k
End If
Next j
Pivot = m(r(i), c(i))
If Pivot <> 1 Then
For k = 1 To row
m(r(i), k) = m(r(i), k) / Pivot
ReturnValue(r(i), k) = ReturnValue(r(i), k) / Pivot
Next k
End If
For j = 1 To row
Pivot = m(j, c(i))
If j <> r(i) And Pivot <> 0 Then
For k = 1 To row
m(j, k) = m(j, k) - m(r(i), k) * Pivot
ReturnValue(j, k) = ReturnValue(j, k) - ReturnValue(r(i), k) * Pivot
Next
End If
Next j
Next i
For i = 1 To row - 1
If r(i) <> c(i) Then
For j = 1 To row
'測試m是否為單位矩陣之用
'temp2(j) = m(r(i), j)
'm(r(i), j) = m(c(i), j)
'm(c(i), j) = temp2(j)
temp(j) = ReturnValue(r(i), j)
ReturnValue(r(i), j) = ReturnValue(c(i), j)
ReturnValue(c(i), j) = temp(j)
Next
For j = i + 1 To row
If r(j) = c(i) Then r(j) = r(i): Exit For
Next
r(i) = c(i)
End If
Next
End Sub
全站熱搜
留言列表