VBA: completing a matrix

Question

I have a 3 by 3 matrix, where elements (1,1), (2,1), (2,2), (3,1), (3,2), (3,3) are given:

X   .   .
X   X   .
X   X   X

I need to write a program that writes out the missing elements, where (1,2)=(2,1), (1,3)=(3,1) and (2,3)=(3,2). I have written the following code:

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

However, this does not seem to work, could anybody help me why is this not working?

Answer 1

Get twin data in 2-dim matrix avoiding extra n*(n-1)/2 condition checks

The following approach

• reduces the number of unnecessary condition checks by incrementing the 2nd loop starts
• accepts any wanted base of 2-dim data:

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

An example call creating e.g. a 1-based 2-dim datafield array might be

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

Further link

A practical example using such a mirrored array might be a distance array; a related post demonstrates how to apply the FilterXML() function thereon.

Answer 2

Fill Array

• Using a method (fillArray) you could modify the array 'in place':

The Code

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

A Homage to T.M.'s Brilliant Solution

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

Answer 3

Just remove the Else condition:

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