如何根据第一行和第一列中的值对一系列矩阵求和 - Excel VBA

Question

我有一系列 5x5 矩阵（总共 20 个），我需要创建一个全局矩阵，根据第一行和第一列的相应值对矩阵的 4x4 部分求和。参考下图。

https://i.stack.imgur.com/xUAEL.png 装箱的 4x4 矩阵是我需要求和的元素。

全局矩阵将是与第一行和第一列匹配的所有对应值的总和。例如，在上图中，k1 和 k2 中的值相加将是对应于的单元格 10,10（两个 4x4 矩阵的左上角），即 0.000 + 0.010。矩阵 k3 和 k4 没有 10,10 单元格，因此不会从这些矩阵中添加任何值。

所以全局矩阵看起来类似于下图（注意矩阵不完整）。

https://i.smage 在这里描述]3]3 如果可能的话，我想编写一个可以执行此操作的宏，以节省我必须手动执行的操作。我尝试了几个匹配功能，但鉴于我的新手编码能力，似乎无法使用它。

任何建议将不胜感激。

Answer 1

求和矩阵

• 仔细调整常量部分中的值。

守则

Option Explicit

Sub sumMatrices()
    ' Source
    Const srcName As String = "Sheet1"
    Const srcFirstCell As String = "A1"
    Const hGap As Long = 2
    Const vGap As Long = 2
    Const hCount As Long = 10
    Const vCount As Long = 2
    Const hSize As Long = 5
    Const vSize As Long = 5
    ' Target
    Const tgtName As String = "Sheet2"
    Const tgtFirstCell As String = "B2"
    Const hMax As Long = 20
    Const vMax As Long = 20
    ' Other
    Dim wb As Workbook
    Set wb = ThisWorkbook ' The workbook containing this code.
    
    ' Define first Source Range.
    Dim src As Worksheet
    Set src = wb.Worksheets(srcName)
    Dim rng As Range
    Set rng = src.Range(srcFirstCell).Resize(hSize, vSize)
    
    ' Write values from Source Ranges to arrays of Jagged Source Array.
    
    Dim Source As Variant
    ReDim Source(1 To hCount * vCount)
        
    Dim hOffs As Long
    Dim vOffs As Long
    hOffs = hSize + hGap
    vOffs = vSize + vGap
    
    Dim hCurr As Long
    Dim vCurr As Long
    Dim i As Long
    Dim j As Long
    Dim l As Long
    
    For i = 1 To hCount
        hCurr = (i - 1) * hOffs
        For j = 1 To vCount
            vCurr = (j - 1) * vOffs
            l = l + 1
            Source(l) = rng.Offset(hCurr, vCurr).Value
        Next j
    Next i
    
    ' Write values from arrays of Jagged Source Array to Target Array.
    Dim Target As Variant
    ReDim Target(1 To hMax, 1 To vMax)
    
    For l = 1 To UBound(Source)
        For i = 2 To hSize
            For j = 2 To vSize
                Target(Source(l)(i, 1), Source(l)(1, j)) _
                  = Target(Source(l)(i, 1), Source(l)(1, j)) _
                  + Source(l)(i, j)
            Next j
        Next i
    Next l
    
    ' Write values from Target Array to Target Range.
    Dim tgt As Worksheet
    Set tgt = wb.Worksheets(tgtName)
    tgt.Range(tgtFirstCell).Resize(hMax, vMax).Value = Target
    
    ' Inform user.
    MsgBox "Data transferred.", vbInformation, "Success"

End Sub

Answer 2

预先将结果做成数组后，可以根据索引号添加各个区域的内容。

Sub test()
    Dim vResult(1 To 20, 1 To 20)
    Dim vDB As Variant
    Dim rngTable As Range
    Dim rng As Range
    Dim i As Integer, j As Integer
    
    '5x5 Matrix first cell
    Set rngTable = Range("d2,d10,L2,L10") '<~~ Add more first cells from another table.
    
    For Each rng In rngTable
        vDB = rng.Resize(5, 5)
        For i = 2 To 5
            For j = 2 To 5
                vResult(vDB(i, 1), vDB(1, j)) = vResult(vDB(i, 1), vDB(1, j)) + vDB(i, j)
            Next j
        Next i
    Next rng
    
    'Result Matrix
    'The result is displayed based on cell e19, but if the cell position is adjusted, the result is displayed in another cell.
    Range("e19").Resize(UBound(vResult, 1), UBound(vResult, 2)) = vResult

End Sub

图片