用excel解线性方程组(宏代码)
- 1、下载文档前请自行甄别文档内容的完整性,平台不提供额外的编辑、内容补充、找答案等附加服务。
- 2、"仅部分预览"的文档,不可在线预览部分如存在完整性等问题,可反馈申请退款(可完整预览的文档不适用该条件!)。
- 3、如文档侵犯您的权益,请联系客服反馈,我们会尽快为您处理(人工客服工作时间:9:00-18:30)。
打开excel,按alt+f8,编辑宏,把下面的代码全覆盖上去:
Dim n As Integer
Sub setextent()
Dim x As Integer
'clear
Range("A1").Select
If Selection.Borders(xlEdgeRight).Weight = xlThick Then
x = MsgBox("are you sure to clear?", vbOKCancel, "setextent")
If x = vbCancel Then Exit Sub
n = 1
Range(rangeselect(1, 0)).Select
Do Until Selection.Borders(xlEdgeRight).Weight = xlThick
n = n + 1
Range(rangeselect(n, 0)).Select
Loop
Range("A1:" & rangeselect(n + 1, n)).Select
Selection.ClearContents
Selection.Borders.LineStyle = xlLineStyleNone
End If
'input
n = InputBox("setextent(1 to 700+)", "setextent")
If n > 1 Then
Range("A1:" & rangeselect(n + 1, n)).Select
Selection.Borders(xlEdgeRight).Weight = xlThick
Selection.Borders(xlEdgeBottom).Weight = xlThick
Range("A1:" & rangeselect(n, n)).Select
Selection.Borders(xlEdgeRight).Weight = xlThick
Range("A1:" & rangeselect(n + 1, 0)).Select
Selection.Borders(xlEdgeBottom).Weight = xlThick
Range("A1:A" & n + 1).Select
Selection.Borders(xlEdgeRight).Weight = xlThick
Range("A1").Select
ActiveCell.FormulaR1C1 = "方程编号"
Range(rangeselect(n + 1, 0)).Select
ActiveCell.FormulaR1C1 = "ans"
If n > 1 Then
For x = 2 To n
Range("A" & x & ":" & rangeselect(n + 1, x - 1)).Select
Selection.Borders(xlEdgeBottom).Weight = xlThin
Next
End If
For x = 1 To n
Range(rangeselect(x, 0)).Select
ActiveCell.FormulaR1C1 = x
Next
For x = 1 To n
Range("A" & x + 1).Select
ActiveCell.FormulaR1C1 = x
Next
Range("B2").Select
Else
MsgBox "please reinput n", , "setextent"
n = 0
End If
End Sub
Sub solvelineequations()
'check
n = 0
Range("A1").Select
If Selection.Borders(xlEdgeRight).Weight = xlThick Then
n = 1
Range(rangeselect(n, 0)).Select
Do Until Selection.Borders(xlEdgeRight).Weight = xlThick
n = n + 1
Range(rangeselect(n, 0)).Select
Loop
End If
If n = 0 Or n = 1 Then
MsgBox "please set the extent", , "solve"
Exit Sub
End If
Dim i As Integer
Dim j As Integer
Dim k As Integer
'input
ReDim a(n, n) As Double
ReDim b(n) As Double
For i = 1 To n
For j = 1 To n
Range(rangeselect(j, i)).Select
If Range(rangeselect(j, i)).Text = "" Then
a(i, j) = 0
Else
a(i, j) = Range(rangeselect(j, i)).Text
End If
Next
Range(rangeselect(n + 1, i)).Select
If Range(rangeselect(n + 1, i)).Text = "" Then
b(i) = 0
Else
b(i) = Range(rangeselect(n + 1, i)).Text
End If
Next
'calculating
Sheets("Sheet1").Copy after:=Sheets("Sheet1")
'step1
For i = 1 To n - 1
'change the seat
If a(i, i) = 0 Then
j = i + 1
Do Until a(j, i) <> 0
j = j + 1
If j > n Then
MsgBox "please check your input", , "solve"
Exit Sub
End If
Loop
b(i) = b(i) + b(j)
b(j) = b(i) - b(j)
b(i) = b(i) - b(j)
For k = i To n
a(i, k) = a(i, k) + a(j, k)
a(j, k) = a(i, k) - a(j, k)
a(i, k) = a(i, k) - a(j, k)
Next
End If
'inmulti
b(i) = b(i) / a(i, i)
Range(rangeselect(n + 1, i)).Select
ActiveCell.FormulaR1C1 = b(i)
For j = n To i Step -1
a(i, j) = a(i, j) / a(i, i)
Range(rangeselect(j, i)).Select
ActiveCell.FormulaR1C1 = a(i, j)
Next
'minus
For j = i + 1 To n
For k = i + 1 To n
a(j, k) = a(j, k) - a(i, k) * a(j, i)
Range(rangeselect(k, j)).Select
ActiveCell.FormulaR1C1 = a(j, k)
Next
b(j) = b(j) - b(i) * a(j, i)
Range(rangeselect(n + 1, j)).Select
ActiveCell.FormulaR1C1 = b(j)
a(j, i) = 0
Range(rangeselect(i, j)).Select
ActiveCell.FormulaR1C1 = a(j, i)
Next
Next
If a(n, n) = 0 Then
MsgBox "please check your input", , "solve"
Exit Sub
End If
b(n) = b(n) / a(n, n)
Range(rangeselect(n + 1, n)).Select
ActiveCell.FormulaR1C1 = b(n)
a(n, n) = 1
Range(rangeselect(n, n)).Select
ActiveCell.FormulaR1C1 = a(n, n)
'step2
For i = n - 1 To 1 Step -1
For j = i + 1 To n
b(i) = b(i) - b(j) * a(i, j)
Range(rangeselect(n + 1, i)).Select
ActiveCell.FormulaR1C1 = b(i)
a(i, j) = 0
Range(rangeselect(j, i)).Select
ActiveCell.FormulaR1C1 = a(i, j)
Next
Next
'output
'For i = 1 To n
' For j = 1 To n
' Range(Chr(65 + j) & i + 1).Select
' ActiveCell.FormulaR1C1 = a(i, j)
' Next
' Range(Chr(66 + n) & i + 1).Select
' ActiveCell.FormulaR1C1 = b(i)
'Next
MsgBox "done", , "solve"
End Sub
Private Function rangeselect(x As Integer, y As Integer) As String
Dim z As Integer
Dim w As Integer
z = x + 1
w = y + 1
'step1
If z > 0 And z <= 26 Then
rangeselect = Chr(64 + z)
Else
If z > 26 And z <= 702 Then
rangeselect = Chr(64 + z \ 26) & Chr(65 + z Mod 26)
Else
rangeselect = Chr(64 + z \ 676) & Chr(65 + (z Mod 676) \ 26) & Chr(65 + z Mod 26)
End If
End If
'step2
rangeselect = rangeselect & w
End Function