excel - 线性系统求解(N*N矩阵乘法)，VBA

Question

我有 2 个数组。 Array1 是 n * n，Array2 是 1 * n。

这些数组在工作表中给出。在这种情况下，Sheet3 和 Sheet4 以及我需要在 Sheet5 上输出答案。

我收到多个错误，例如“下标超出范围”。

我似乎无法弄清楚为什么这不起作用:

Public Sub LinearSystemSolver()

x = Sheet3.UsedRange.Rows.Count
y = Sheet3.UsedRange.Columns.Count
Z = Sheet4.UsedRange.Rows.Count

Dim a As Variant
ReDim a(1 To x, 1 To y)
Dim b As Variant
ReDim b(1 To Z, 1 To 1)
Dim g As Variant
ReDim g(1 To Z, 1 To 1)

For i = 1 To x
    For j = 1 To y
    a(i, j) = Sheet3.Cells(i, j)
    Next
Next
For f = 1 To Z
    b(f,1) = Sheet4.Cells(f,1)
Next

g = Application.WorksheetFunction.MMult((Application.WorksheetFunction.MInverse(a)), b)

For h = 1 To Z
    Sheet5.Cells(h, 1) = g(h, 1)
Next

End Sub

Answer 1

您可以通过直接分配给数组并避免循环来加速您的代码

a = Sheet3.Range("A1").Resize(x,y).Value
b = Sheet4.Range("A1").Resize(z,1).Value

...

Sheet5.Range("A1").Resize(z,1).Value = g

现在就反转矩阵(如果 x=y=z)而言，我建议使用 LU 分解。我附上了一个我已经使用多年的工作示例。

驱动代码是

Private Sub solveButton_Click()

    Dim lu As New LuSolver
    ' Get Matrix values and decompose them into L, U, P form
    ' Values are in B3 and matrix is a 5×5 size
    lu.IntializeFromRange Range("B3"), 5
    ' Solve the A*x=b matrix system for x
    ' right hand side is in J3 and it is a 5×1 size
    ' resulting 5×1 matrix will be placed under H3
    lu.Solve Range("J3"), 1, Range("H3")

End Sub

在名为“LuSolver”的类中使用 LU 求解器

'---------------------------------------------------------------------------------------
' Module    : LuSolver
' DateTime  : 6/30/2008 13:01
' Author    : ja72
' Purpose   : LU Decomposition of rectangular matrix.
' Remarks:
'For an n-by-n matrix A, the LU decomposition is an n-by-n
'unit lower triangular matrix L, an n-by-n upper triangular matrix U,
'and a permutation vector piv of length n so that A(piv)=L*U.
'---------------------------------------------------------------------------------------
Option Explicit

Private lu As Variant
Private sign As Integer
Private pivot() As Integer
Private size As Integer

Private Sub Class_Initialize()
    Set lu = Nothing
    Erase pivot
    sign = 1
End Sub

Private Sub Class_Terminate()
    Set lu = Nothing
    Erase pivot
    sign = 0
End Sub


Public Sub IntializeFromRange(ByRef r_coef As Range, ByVal matrix_size As Integer)
    Dim k_max As Integer, k As Integer, p As Integer
    Dim i As Integer, j As Integer
    Dim s As Variant

   On Error GoTo IntializeFromRange_Error

    lu = r_coef.Resize(matrix_size, matrix_size).Value
    size = matrix_size

    'Set pivot as a sequence of integers
    ReDim pivot(1 To size)
    For i = 1 To size
        pivot(i) = i
    Next i
    sign = 1

    For j = 1 To size
        'Apply previous transformations
        For i = 1 To size
            If j > i Then k_max = i Else k_max = j
            s = 0
            'Time consuming dot product
            For k = 1 To k_max - 1
                s = s + lu(i, k) * lu(k, j)
            Next k
            lu(i, j) = lu(i, j) - s
        Next i
        'Find the pivot element
        p = j
        For i = j + 1 To size
            If Abs(lu(i, j)) > Abs(lu(p, j)) Then
                p = i
            End If
        Next i

        'Exchange pivot rows
        If p <> j Then
            For k = 1 To size
                s = lu(p, k)
                lu(p, k) = lu(j, k)
                lu(j, k) = s
            Next k
            k = pivot(p)
            pivot(p) = pivot(j)
            pivot(j) = k
            sign = -sign
        End If

        'Compute Multipliers
        s = lu(j, j)
        If j <= size And s <> 0 And s <> 1 Then
            For i = j + 1 To size
                lu(i, j) = lu(i, j) / s
            Next i
        End If
    Next j

   On Error GoTo 0
   Exit Sub

IntializeFromRange_Error:

    MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure IntializeFromRange of Class Module LuDecomposition"

End Sub

Public Property Get IsSingular() As Boolean
    IsSingular = Not IsNonSingular
End Property
Public Property Get IsNonSingular() As Boolean
    IsNonSingular = True
    Dim j As Integer
    For j = 1 To size
        If lu(j, j) = 0 Then
            IsNonSingular = False
            Exit Property
        End If
    Next j
End Property

Public Sub Solve(ByRef r_rhs As Range, ByVal no_of_columns, ByRef r_result As Range)
   On Error GoTo Solve_Error
    Dim rhs As Variant
    Dim N As Integer, M As Integer, r As Integer
    Dim i As Integer, j As Integer, k As Integer
    N = size
    M = size
    r = no_of_columns
    rhs = r_rhs.Resize(size, r).Value
    'Copy rhs with pivoting
    Dim X As Variant
    ReDim X(1 To size, 1 To r)
    For i = 1 To size
        For j = 1 To r
            X(i, j) = rhs(pivot(i), j)
        Next j
    Next i

    'Solve L*Y = B
    For k = 1 To M
        For i = k + 1 To M
            For j = 1 To r
                X(i, j) = X(i, j) - X(k, j) * lu(i, k)
            Next j
        Next i
    Next k

    'Solve U*X=Y
    For k = M To 1 Step -1
        For j = 1 To r
            X(k, j) = X(k, j) / lu(k, k)
        Next j

        For i = 1 To k - 1
            For j = 1 To r
                X(i, j) = X(i, j) - X(k, j) * lu(i, k)
            Next j
        Next i
    Next k

    r_result.Resize(size, no_of_columns).Value = X

On Error GoTo 0
   Exit Sub

Solve_Error:

    MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure Solve of Class Module LuDecomposition"
End Sub