Public Function Determinant(m() As Single) As Single Dim i As Long, j As Long, k As Long, row As Long, order As Long Dim r As Long, c As Long, Pivot As Single, Pivot2 As Single, temp() As Single Determinant = 1 row = UBound(m, 1) If UBound(m, 2) <> row Then MsgBox "这不是方阵": Exit Function ReDim temp(1 To row) For i = 1 To row Pivot = 0 For j = i To row For k = i To row If Abs(m(k, j)) > Pivot Then Pivot = Abs(m(k, j)) r = k: c = j End If Next k Next j If Pivot = 0 Then Determinant = 0: Exit Function If r <> i Then order = order + 1 For j = 1 To row temp(j) = m(i, j) m(i, j) = m(r, j) m(r, j) = temp(j) Next j End If If c <> i Then order = order + 1 For j = 1 To row temp(j) = m(j, i) m(j, i) = m(j, c) m(j, c) = temp(j) Next j End If Pivot = m(i, i) Determinant = Determinant * Pivot For j = i + 1 To row Pivot2 = m(j, i) If Pivot2 <> 0 Then For k = 1 To row m(j, k) = m(j, k) - m(i, k) * Pivot2 / Pivot Next End If Next Next Determinant = Determinant * (-1) ^ order End Function

Private Sub Command1_Click() Dim Keyin As String, m() As Single Keyin = InputBox("请输入方阵(square matrix)，& vbNewLine& vbNewLine ")

If SepStrToMatrix(Keyin, ";", " ", m) Then Debug.Print Determinant(m) Else MsgBox "矩阵输入有误，请重新输入。" End If End Sub Public Function SepStrToMatrix(TreatStr As String, RowSepChr As String, _ ColSepChr As String, Returnvalue() As Single) 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 Dim row As Long, SepStr() As String 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 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