时间戳

首页 > 解决方案 > 使用 VBA 的矩阵乘法

vba - 使用 VBA 的矩阵乘法

问题描述

我正在尝试使用 VBA 将 2x3 矩阵和 3x2 矩阵相乘。但是，我没有得到预期的输出。比如我得到的两个矩阵和输出是： 输入矩阵和我得到的输出。

在此处输入图像描述 这是错误的输出，但我不明白如何修复它以获得正确的输出。任何帮助将非常感激。



Sub MatrixMult2()

Dim inp1(1, 2) As Integer
Dim inp2(2, 1) As Integer

Dim out(1, 1) As Integer

For j = 0 To 1
For i = 0 To 1

    inp1(i, j) = Range("A28").Cells(i + 1, j + 2)
    inp2(i, j) = Range("E28").Cells(i + 2, j + 1)

Next i
Next j


Dim temp As Integer

For a = 0 To 1
    For b = 0 To 1
        For c = 0 To 2

            temp = temp + inp1(a, c) * inp2(c, b)

        Next c
        out(a, b) = temp
        temp = 0
    Next b
Next a

For j = 0 To 1
For i = 0 To 1
Range("H28").Cells(i + 1, j + 1) = out(i, j)
Next i
Next j

End Sub

标签： vba

解决方案

矩阵

由于我对矩阵的了解并没有超出第一张图片中的三个句子，因此请谨慎使用其中的任何一个。

矩阵乘法（维基百科）

Excel -MMULT

表 1

对于左侧示例，将以下公式复制到单元格中H2：

=MMULT(A2:C3,E2:F4)

现在选择单元格H2并将范围扩展到在单元格处于活动状态时选择I3范围（其颜色为，而其他单元格为）。点击进入公式栏并使用+ +确认。当您查看公式栏时，四个单元格中的每一个（视觉上）都具有相同的公式：H2:I3H2whitegrayCTRLSHIFTENTER

{=MMULT(A2:C3,E2:F4)}

其中大括号 ({和}) 仅表示这是一个数组公式。大括号已自动添加，请勿尝试手动添加。

对于正确的示例，将以下公式复制到单元格中R7：

=MMULT(N2:P5,R2:V4)

现在选择单元格R7并将范围扩展到在单元格处于活动状态时选择V10范围（其颜色为，而其他单元格为）。点击进入公式栏并使用+ +确认。当您查看公式栏时，二十个单元格中的每一个（视觉上）都有相同的公式：R7:V10R7whitegrayCTRLSHIFTENTER

{=MMULT(N2:P5,R2:V4)}

其中大括号 ({和}) 仅表示这是一个数组公式。大括号已自动添加，请勿尝试手动添加。

表 1

表 2

根据您的代码，您可以在单元格中使用以下公式H28：

=MMULT(A28:C29,E28:F30)

现在选择单元格H28并将范围扩展到在单元格处于活动状态时选择I29范围（其颜色为，而其他单元格为）。点击进入公式栏并使用+ +确认。当您查看公式栏时，四个单元格中的每一个（视觉上）都具有相同的公式：H28:I29H28whitegrayCTRLSHIFTENTER

{=MMULT(A28:C29,E28:F30)}

其中大括号 ({和}) 仅表示这是一个数组公式。大括号已自动添加，请勿尝试手动添加。

表 2

VBA

根据需要调整常量。

Option Explicit

' The Sub Solutions

' Sub Version (No Functions Used)
Sub writeMatrixProductSub()

    Const Sheet As String = "Sheet2"
    Const rngM1 As String = "A28:C29"
    Const rngM2 As String = "E28:F30"
    Const celMP As String = "H28"

    Dim M1, M2, MP, Row1 As Long, Col1Row2 As Long, Col2 As Long, Curr As Double

    ' Read from worksheet and write to arrays.
    With ThisWorkbook.Worksheets(Sheet)
        M1 = .Range(rngM1)
        M2 = .Range(rngM2)
    End With

    ' Calculate in arrays.
    If UBound(M1, 2) <> UBound(M2) Then Exit Sub
    ReDim MP(1 To UBound(M1), 1 To UBound(M2, 2))
    For Col2 = 1 To UBound(M2, 2)
        For Row1 = 1 To UBound(M1)
            For Col1Row2 = 1 To UBound(M1, 2)
                Curr = Curr + M1(Row1, Col1Row2) * M2(Col1Row2, Col2)
            Next Col1Row2
            MP(Row1, Col2) = Curr: Curr = 0
        Next Row1
    Next Col2

    ' Check values of Matrix Product in Immediate window.
'    For Row1 = 1 To UBound(MP)
'        For Col1Row2 = 1 To UBound(MP, 2)
'            Debug.Print MP(Row1, Col1Row2)
'        Next
'    Next

    ' Write to worksheet.
    With ThisWorkbook.Worksheets(Sheet)
        .Range(celMP).Resize(UBound(MP), UBound(MP, 2)) = MP
    End With

End Sub

' Sub Version Using "WorksheetFunction.MMult" with qualified worksheet
Sub writeMatrixProductMMultSubQualify()
    Const Sheet As String = "Sheet2"
    Const rngM1 As String = "A28:C29"
    Const rngM2 As String = "E28:F30"
    Const celMP As String = "H28"
    Dim M1, M2, MP
    With ThisWorkbook.Worksheets(Sheet)
        M1 = .Range(rngM1)
        M2 = .Range(rngM2)
        If UBound(M1, 2) <> UBound(M2) Then Exit Sub
        ReDim MP(1 To UBound(M1), 1 To UBound(M2, 2))
        MP = WorksheetFunction.MMult(M1, M2)
        .Range(celMP).Resize(UBound(MP), UBound(MP, 2)) = MP
    End With
End Sub

' Sub Version Using "WorksheetFunction.MMult"
Sub writeMatrixProductMMultSub()
    Const rngM1 As String = "A28:C29"
    Const rngM2 As String = "E28:F30"
    Const celMP As String = "H28"
    Dim M1, M2, MP
    M1 = Range(rngM1)
    M2 = Range(rngM2)
    If UBound(M1, 2) <> UBound(M2) Then Exit Sub
    ReDim MP(1 To UBound(M1), 1 To UBound(M2, 2))
    MP = WorksheetFunction.MMult(M1, M2)
    Range(celMP).Resize(UBound(MP), UBound(MP, 2)) = MP
End Sub

' The Function Solutions

'  Sub Using "writeMatrixProduct" and "getMatrixProduct1"
Sub testMatrixProductSimple()
    Const rngM1 As String = "A28:C29"
    Const rngM2 As String = "E28:F30"
    Const celMP As String = "H28"
    writeMatrixProduct Range(rngM1), Range(rngM2), Range(celMP)
End Sub

'  Sub Using "writeMatrixProduct" and "getMatrixProduct1" with Checking
Sub testMatrixProductCheck()
    Const rngM1 As String = "A28:C29"
    Const rngM2 As String = "E28:F30"
    Const celMP As String = "H28"
    Dim Success As Boolean
    Success = writeMatrixProduct(Range(rngM1), Range(rngM2), Range(celMP))
    If Success Then
        MsgBox "Write was successful.", vbInformation
    Else
        MsgBox "Write was unsuccessful. Nothing written.", vbExclamation
    End If
End Sub

' The Functions

' Remarks:      2D 1-based is convenient for operating in ranges.

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Using the "getMatrixProduct1" function, writes the matrix      '
'               product of two matrices contained in ranges to another range.  '
' Returns:      A boolean indicating if the operation was successful.          '
' Remarks:      The resulting range is specified only by its first cell.       '
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function writeMatrixProduct(Matrix1 As Range, Matrix2 As Range, _
  MatrixProductFirstCell As Range) As Boolean
    Dim M1, M2, MP
    On Error GoTo handleError
    M1 = Matrix1: M2 = Matrix2
    MP = getMatrixProduct1(M1, M2)
    If Not IsArray(MP) Then Exit Function
    MatrixProductFirstCell.Resize(UBound(MP), UBound(MP, 2)) = MP
    writeMatrixProduct = True
exitProcedure:
Exit Function
handleError:
    Debug.Print "Run-time error '" & Err.Number & "': " & Err.Description
    Resume exitProcedure
End Function
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Returns a 2D 1-based array containing the matrix product       '
'               of two matrices contained in 2D 1-based arrays.                '
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function getMatrixProduct1(Matrix1 As Variant, Matrix2 As Variant) As Variant
    If UBound(Matrix1, 2) <> UBound(Matrix2) Then Exit Function
    Dim MP, Row1 As Long, Col1Row2 As Long, Col2 As Long, Curr As Double
    ReDim MP(1 To UBound(Matrix1), 1 To UBound(Matrix2, 2))
    For Col2 = 1 To UBound(Matrix2, 2)
        For Row1 = 1 To UBound(Matrix1)
            For Col1Row2 = 1 To UBound(Matrix1, 2)
                Curr = Curr + Matrix1(Row1, Col1Row2) * Matrix2(Col1Row2, Col2)
            Next Col1Row2
            MP(Row1, Col2) = Curr: Curr = 0
        Next Row1
    Next Col2
    getMatrixProduct1 = MP
End Function
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Returns a 2D 1-based array containing the matrix product       '
'               of two matrices contained in 2D 1-based arrays.                '
' Remarks:      While testing it turned out to be over 10 times slower than    '
'               the "getMatrixProduct1" function (needs to be verified).       '
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function getMatrixProduct1M(Matrix1 As Variant, Matrix2 As Variant) As Variant
    If UBound(Matrix1, 2) <> UBound(Matrix2) Then Exit Function
    Dim MP: ReDim MP(1 To UBound(Matrix1), 1 To UBound(Matrix2, 2))
    MP = WorksheetFunction.MMult(Matrix1, Matrix2): getMatrixProduct1M = MP
End Function
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

推荐阅读