VBA：完成矩阵答案

【问题标题】：VBA: completing a matrixVBA：完成矩阵
【发布时间】：2021-05-29 15:56:00
【问题描述】：

我有一个 3 x 3 矩阵，其中给出了元素 (1,1)、(2,1)、(2,2)、(3,1)、(3,2)、(3,3) ：

X   .   .
X   X   .
X   X   X

我需要编写一个程序来写出缺少的元素，其中 (1,2)=(2,1), (1,3)=(3,1) 和 (2,3)=(3, 2）。我写了以下代码：

Function kiegeszito(a)
    For i = 1 To 3
        For j = 1 To 3
            If i < j Then
                a(i, j) = a(j, i)
            Else        
                a(i, j) = a(i, j)
            End If
        Next j
    Next i

    kiegeszito = a
End Function

但是，这似乎不起作用，任何人都可以帮助我为什么这不起作用？

【问题讨论】：

它们都是很好的答案，但恕我直言，不工作的原因只是您需要将函数的第一行更改为 Sub kiegeszito(ByRef a As Variant) 最后一行到 End子并取出 kiegeszito = a。实际代码（虽然可能不是最有效的）是正确的。

标签： excel vba function matrix

【解决方案1】：

只需删除Else 条件：

Function kiegeszito(a)
    For i = 1 To 3
        For j = 1 To 3
            If i < j Then a(i, j) = a(j, i)
        Next j
    Next i

    kiegeszito = a
End Function

【讨论】：

【解决方案2】：

填充数组

使用方法 (fillArray) 您可以“就地”修改数组：

守则

Option Explicit

Sub fillArrayTEST()
    Dim Data As Variant: Data = Range("A1:C3").Value
    debugPrint2D Data
    fillArray Data
    debugPrint2D Data
End Sub

Sub fillArray(ByRef Data As Variant)
    Dim cCount As Long: cCount = UBound(Data, 2)
    Dim i As Long, j As Long
    For i = 1 To UBound(Data, 1)
        For j = 1 To cCount
            If i < j Then Data(i, j) = Data(j, i)
        Next j
    Next i
End Sub

Sub debugPrint2D(ByVal Data As Variant)
    Dim i As Long, j As Long
    For i = LBound(Data, 1) To UBound(Data, 1)
        For j = LBound(Data, 2) To UBound(Data, 2)
            Debug.Print "[" & i & "," & j & "]", Data(i, j)
        Next j
    Next i
End Sub

向 T.M. 的出色解决方案致敬

Sub completeMatrix(ByRef Data As Variant)
    Dim rLower As Long: rLower = LBound(Data, 1)
    Dim cLower As Long: cLower = LBound(Data, 2)
    Dim iDiff As Long: iDiff = cLower - rLower
    Dim cStart As Long: cStart = iDiff + 1
    Dim cUpper As Long: cUpper = UBound(Data, 2)
    Dim r As Long, c As Long
    For r = rLower To UBound(Data, 1) - rLower
        For c = cStart + r To cUpper
            Data(r, c) = Data(c - iDiff, r + iDiff)
        Next c
    Next r
End Sub

Sub completeMatrixTEST()
    Dim Data As Variant: ReDim Data(0 To 2, 2 To 4)
    Data(0, 2) = 1
    Data(1, 2) = 2
    Data(1, 3) = 3
    Data(2, 2) = 4
    Data(2, 3) = 5
    Data(2, 4) = 6
    debugPrint2D Data
    completeMatrix Data
    'Range("G1").Resize(UBound(Data, 1) - LBound(Data, 1) + 1, _
        UBound(Data, 2) - LBound(Data, 2) + 1).Value = Data
    Debug.Print
    debugPrint2D Data
End Sub

【讨论】：

【解决方案3】：

在二维矩阵中获取孪生数据，避免额外的n*(n-1)/2 条件检查

以下做法

通过增加第 2 个循环的开始次数来减少不必要的条件检查次数
接受任何想要的二维数据基数：

Sub CompleteMatrix(ByRef data)
'count row|=column elements
Dim cnt As Long: cnt = UBound(data) - LBound(data) + 1

'fill missing twin data (identified by inverted indices)
Dim i As Long, j As Long
For i = LBound(data) To cnt - 1
    '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    'next column starts from incremented row index
    '(thus avoiding n*(n-1)/2 IF-conditions)
    '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    For j = i + 1 To UBound(data, 2)
        data(i, j) = data(j, i)     ' assign twin data
    Next j
Next i
End Sub

一个示例调用创建例如一个基于 1 的 2-dim 数据字段数组可能是

Sub ExampleCall()
    Dim v: v = Tabelle3.Range("A1:C3").Value
    CompleteMatrix v
End Sub

更多链接

使用这种镜像数组的实际示例可能是距离数组； related post 演示了如何在其上应用 FilterXML() 函数。

【讨论】：