如何根據第一行和第一列中的值對一系列矩陣求和 - 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://is mage description here] 3 ] 3如果可能，我想編寫一個可以執行此操作的宏，以節省我必須手動執行的操作。 我已經嘗試了幾個匹配函數，但鑒於我的新手編碼能力，它似乎無處可去。

任何建議將不勝感激。

Answer 1

預先把結果做成數組后，就可以根據索引號添加各個區域的內容了。

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

圖片

Answer 2

求和矩陣

• 仔細調整常量部分中的值。

編碼

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