VBA array functions (MatLabish/Pythonish implementation)

Nor VBA nor Visual Basic have natively implemented most of the array functions that Python or MatLab (https://www.mathworks.com/help/matlab/functionlist.html) have.

But they can be coded to get similar functionality.

Following are a bunch of functions (code not finished, or even not just started -for those that have a ‘!!!!! at the beginning of the description-), just to get fast creation and operation over matrices in VBA.

Note: This is a work on progress, so it’ll grow in the future with new functions.

Option Explicit
'!!!!!!!!!!!!!!!!!!!
Public Const g_Base As Long = 0
'!!!!!!!!!!!!!!!!!!!
Public Function fNewArray(ByVal strText As String, _
                          Optional ByVal strColSeparator As String = " ", _
                          Optional ByVal strRowSeparator As String = ";", _
                          Optional ByVal strNewLine As String = "\") As Variant
'To reference all the elements in the mth row we type A(:m,).
'To reference all the elements in the nth column we type A(:,n).
'To reference all the elements in the mth to nth column we type A(:,m:n).
'To reference all the elements in the mth to nth row we type A(m:n,:).
'ToDo --> a([2,3,2,3],:)
     '--> Row Vector []
     '--> Column vector {}
    Dim mArray As Variant
     
    'Dim lgDim As Long
    Dim lgElement As Long
    Dim lgElements As Long
    'strEnclosing As String = "[]"
    Dim aVector() As String
    Dim aElement() As String
    Dim lgVector As Long
    Dim strVector As String
    Dim aCreator() As String
    
    strText = VBA.Trim$(strText)
    'Join lines...
    strText = VBA.Replace(strText, vbNewLine, "")
    strText = VBA.Replace(strText, strNewLine, "")
    
    aCreator() = VBA.Split(strText, ":")
    If LBound(aCreator)  UBound(aCreator) Then
    ' array = [first : second : ... : last]
        If (2 = (UBound(aCreator) - LBound(aCreator) + 1)) Then
            ReDim mArray(g_Base + 0 To g_Base + aCreator()(LBound(aCreator)), _
                         g_Base + 0 To g_Base + aCreator()(UBound(aCreator)))
        ElseIf (3 = (UBound(aCreator) - LBound(aCreator) + 1)) Then
            ReDim mArray(g_Base + 0 To g_Base + aCreator()(LBound(aCreator) + 0) - 1, _
                         g_Base + 0 To g_Base + aCreator()(LBound(aCreator) + 1) - 1, _
                         g_Base + 0 To g_Base + aCreator()(UBound(aCreator)) - 1)
        End If
    
    Else
        If strText Like "[[]*" Then
         '--> Row Vector []
            If strText Like "*]" Then
                strText = VBA.Mid$(strText, 2, VBA.Len(strText) - 2)
                strText = VBA.Trim$(strText)
                
                'Get vectors
                aVector = VBA.Split(strText, strRowSeparator)
                strVector = VBA.Trim$(aVector()(LBound(aVector)))
                
                'Avoid repeated separators
                Do While VBA.InStr(1, strVector, (strColSeparator & strColSeparator)) > 0
                    strVector = VBA.Replace(strVector, strColSeparator & strColSeparator, strColSeparator)
                Loop
                aElement = VBA.Split(strVector, strColSeparator)
                ReDim mArray(g_Base + LBound(aVector) To g_Base + UBound(aVector), _
                             g_Base + LBound(aElement) To g_Base + UBound(aElement))
                
                For lgVector = LBound(aVector) To UBound(aVector)
                    strVector = VBA.Trim$(aVector(lgVector))
                    
                    'Avoid repeated separators
                    Do While VBA.InStr(1, strVector, (strColSeparator & strColSeparator)) > 0
                        strVector = VBA.Replace(strVector, strColSeparator & strColSeparator, strColSeparator)
                    Loop
                    aElement = VBA.Split(strVector, strColSeparator)
                    For lgElement = LBound(aElement) To UBound(aElement)
                        mArray(g_Base + lgVector, g_Base + lgElement) = VBA.Val(aElement(lgElement))
                    Next lgElement
                Next lgVector
            End If
        
        ElseIf strText Like "{*" Then
         '--> Column vector {}
            If strText Like "*}" Then
                strText = VBA.Mid$(strText, 2, VBA.Len(strText) - 1)
            
                'Join lines...
                strText = VBA.Replace(strText, strNewLine, "")
                
                'Get Columns
                aVector = VBA.Split(strText, strColSeparator)
                strVector = VBA.Trim$(aVector()(LBound(aVector)))
                
                'Avoid repeated separators
                Do While VBA.InStr(1, strVector, (strRowSeparator & strRowSeparator)) > 0
                    strVector = VBA.Replace(strVector, strRowSeparator & strRowSeparator, strRowSeparator)
                Loop
                aElement = VBA.Split(strVector, strRowSeparator)
                ReDim mArray(g_Base + LBound(aElement) To g_Base + UBound(aElement), _
                             g_Base + LBound(aVector) To g_Base + UBound(aVector))
                
                For lgVector = LBound(aVector) To UBound(aVector)
                    strVector = VBA.Trim$(aVector(lgVector))
                    
                    'Avoid repeated separators
                    Do While VBA.InStr(1, strVector, (strRowSeparator & strRowSeparator)) > 0
                        strVector = VBA.Replace(strVector, strRowSeparator & strRowSeparator, strRowSeparator)
                    Loop
                    aElement = VBA.Split(strVector, strRowSeparator)
                    For lgElement = LBound(aElement) To UBound(aElement)
                        mArray(g_Base + lgVector, g_Base + lgElement) = VBA.Val(aElement(lgElement))
                    Next lgElement
                Next lgVector
            End If
        End If
    End If
    
    fNewArray = mArray
    Erase aCreator()
End Function

Public Function fNewArrayStr(ByVal strText As String, _
                             Optional ByVal strColSeparator As String = " ", _
                             Optional ByVal strRowSeparator As String = ";", _
                             Optional ByVal strNewLine As String = "\") As String()
    Dim vArray As Variant
    Dim aStr() As String
    Dim lgC As Long
    Dim lgR As Long
    
    vArray = fNewArray(strText, strColSeparator, strRowSeparator, strNewLine)
    If IsArray(vArray) Then
        ReDim aStr(LBound(vArray, 1) To UBound(vArray, 1), _
                   LBound(vArray, 2) To UBound(vArray, 2))
        For lgR = LBound(vArray, 1) To UBound(vArray, 1)
            For lgC = LBound(vArray, 2) To UBound(vArray, 2)
                aStr(lgR, lgC) = VBA.CStr(vArray(lgR, lgC))
            Next lgC
        Next lgR
        fNewArrayStr = aStr()
    
        Erase aStr()
    End If
    Erase vArray
End Function
Public Function fNewArrayDbl(ByVal strText As String, _
                             Optional ByVal strColSeparator As String = " ", _
                             Optional ByVal strRowSeparator As String = ";", _
                             Optional ByVal strNewLine As String = "\") As Double()
    Dim vArray As Variant
    Dim aDbl() As Double
    Dim lgC As Long
    Dim lgR As Long
    
    vArray = fNewArray(strText, strColSeparator, strRowSeparator, strNewLine)
    If IsArray(vArray) Then
        ReDim aDbl(LBound(vArray, 1) To UBound(vArray, 1), _
                   LBound(vArray, 2) To UBound(vArray, 2))
        For lgR = LBound(vArray, 1) To UBound(vArray, 1)
            For lgC = LBound(vArray, 2) To UBound(vArray, 2)
                aDbl(lgR, lgC) = VBA.Val(vArray(lgR, lgC))
            Next lgC
        Next lgR
        fNewArrayDbl = aDbl()
    
        Erase aDbl()
    End If
    Erase vArray
End Function
Public Function fNewArraySng(ByVal strText As String, _
                             Optional ByVal strColSeparator As String = " ", _
                             Optional ByVal strRowSeparator As String = ";", _
                             Optional ByVal strNewLine As String = "\") As Single()
    Dim vArray As Variant
    Dim aSng() As Single
    Dim lgC As Long
    Dim lgR As Long
    
    vArray = fNewArray(strText, strColSeparator, strRowSeparator, strNewLine)
    If IsArray(vArray) Then
        ReDim aSng(LBound(vArray, 1) To UBound(vArray, 1), _
                   LBound(vArray, 2) To UBound(vArray, 2))
        For lgR = LBound(vArray, 1) To UBound(vArray, 1)
            For lgC = LBound(vArray, 2) To UBound(vArray, 2)
                aSng(lgR, lgC) = VBA.CSng(VBA.Val(vArray(lgR, lgC)))
            Next lgC
        Next lgR
        fNewArraySng = aSng()
    
        Erase aSng()
    End If
    Erase vArray
End Function
Public Function fNewArrayLng(ByVal strText As String, _
                             Optional ByVal strColSeparator As String = " ", _
                             Optional ByVal strRowSeparator As String = ";", _
                             Optional ByVal strNewLine As String = "\") As Long()
    Dim vArray As Variant
    Dim aLng() As Long
    Dim lgC As Long
    Dim lgR As Long
    
    vArray = fNewArray(strText, strColSeparator, strRowSeparator, strNewLine)
    If IsArray(vArray) Then
        ReDim aLng(LBound(vArray, 1) To UBound(vArray, 1), _
                   LBound(vArray, 2) To UBound(vArray, 2))
        For lgR = LBound(vArray, 1) To UBound(vArray, 1)
            For lgC = LBound(vArray, 2) To UBound(vArray, 2)
                aLng(lgR, lgC) = VBA.CLng(VBA.Val(vArray(lgR, lgC)))
            Next lgC
        Next lgR
        fNewArrayLng = aLng()
    
        Erase aLng()
    End If
    Erase vArray
End Function
Public Function fNewArrayInt(ByVal strText As String, _
                             Optional ByVal strColSeparator As String = " ", _
                             Optional ByVal strRowSeparator As String = ";", _
                             Optional ByVal strNewLine As String = "\") As Integer()
    Dim vArray As Variant
    Dim aInt() As Integer
    Dim lgC As Long
    Dim lgR As Long
    
    vArray = fNewArray(strText, strColSeparator, strRowSeparator, strNewLine)
    If IsArray(vArray) Then
        ReDim aInt(LBound(vArray, 1) To UBound(vArray, 1), _
                   LBound(vArray, 2) To UBound(vArray, 2))
        For lgR = LBound(vArray, 1) To UBound(vArray, 1)
            For lgC = LBound(vArray, 2) To UBound(vArray, 2)
                aInt(lgR, lgC) = VBA.CInt(VBA.Val(vArray(lgR, lgC)))
            Next lgC
        Next lgR
        fNewArrayInt = aInt()
    
        Erase aInt()
    End If
    Erase vArray
End Function
Public Function fNewArrayBool(ByVal strText As String, _
                              Optional ByVal strColSeparator As String = " ", _
                              Optional ByVal strRowSeparator As String = ";", _
                              Optional ByVal strNewLine As String = "\") As Boolean()
    Dim vArray As Variant
    Dim aBool() As Boolean
    Dim lgC As Long
    Dim lgR As Long
    
    vArray = fNewArray(strText, strColSeparator, strRowSeparator, strNewLine)
    If IsArray(vArray) Then
        ReDim aBool(LBound(vArray, 1) To UBound(vArray, 1), _
                   LBound(vArray, 2) To UBound(vArray, 2))
        For lgR = LBound(vArray, 1) To UBound(vArray, 1)
            For lgC = LBound(vArray, 2) To UBound(vArray, 2)
                aBool(lgR, lgC) = VBA.CBool(VBA.Val(vArray(lgR, lgC)))
            Next lgC
        Next lgR
        fNewArrayBool = aBool()
    
        Erase aBool()
    End If
    Erase vArray
End Function
Public Function fNewArrayByte(ByVal strText As String, _
                              Optional ByVal strColSeparator As String = " ", _
                              Optional ByVal strRowSeparator As String = ";", _
                              Optional ByVal strNewLine As String = "\") As Byte()
    Dim vArray As Variant
    Dim aByte() As Byte
    Dim lgC As Long
    Dim lgR As Long
    
    vArray = fNewArray(strText, strColSeparator, strRowSeparator, strNewLine)
    If IsArray(vArray) Then
        ReDim aByte(LBound(vArray, 1) To UBound(vArray, 1), _
                   LBound(vArray, 2) To UBound(vArray, 2))
        For lgR = LBound(vArray, 1) To UBound(vArray, 1)
            For lgC = LBound(vArray, 2) To UBound(vArray, 2)
                aByte(lgR, lgC) = VBA.CByte(VBA.Val(vArray(lgR, lgC)))
            Next lgC
        Next lgR
        fNewArrayByte = aByte()
    
        Erase aByte()
    End If
    Erase vArray
End Function

Public Function fNewVector(ByVal strText As String, _
                           Optional ByVal strColSeparator As String = " ", _
                           Optional ByVal strRowSeparator As String = ";", _
                           Optional ByVal strNewLine As String = "\") As Variant
' vector = [first : step : last]
' To create a vector v with the first element f, last element l, and the difference between elements is any real number n
    Dim mVector As Variant
    
    Dim aCreator() As String
    Dim aElement() As String
    Dim dbFirst As Double
    Dim dbLast As Double
    Dim dbStep As Double
    Dim lgElement As Long
    Dim lgElements As Long
    Dim lgStep As Long
    Dim strVector As String
    
    strText = VBA.Trim$(strText)
    
    aCreator() = VBA.Split(strText, ":")
    If LBound(aCreator)  UBound(aCreator) Then
        dbFirst = VBA.Val(aCreator()(LBound(aCreator) + 0))
        dbLast = VBA.Val(aCreator()(LBound(aCreator) + 2))
        dbStep = VBA.Val(aCreator()(LBound(aCreator) + 1))
        If dbStep = 0 Then dbStep = 1
        lgElements = VBA.CLng((dbLast - dbFirst) / dbStep)
        ReDim mVector(g_Base + 0 To g_Base + lgElements - 1)
        lgStep = 0
        For lgElement = LBound(mVector) To UBound(mVector)
            mVector(lgElement) = dbFirst + (lgStep * dbStep)
            lgStep = lgStep + 1
        Next lgElement
        If mVector(UBound(mVector))  dbLast Then
            ReDim Preserve mVector(LBound(mVector) To UBound(mVector) + 1)
            mVector(UBound(mVector)) = dbLast
        End If
        fNewVector = mVector
    
    Else
        'Join lines...
        strText = VBA.Replace(strText, strNewLine, "")
        
        If VBA.InStr(1, strText, strRowSeparator) = 0 Then
        'row vector
            'Avoid repeated separators
            Do While VBA.InStr(1, strVector, (strColSeparator & strColSeparator)) > 0
                strVector = VBA.Replace(strVector, strColSeparator & strColSeparator, strColSeparator)
            Loop
            
            aElement() = VBA.Split(strText, strColSeparator)
            
            ReDim mVector(g_Base + LBound(aElement) To g_Base + UBound(aElement))
            For lgElement = LBound(aElement) To UBound(aElement)
                mVector(lgElement) = VBA.Val(aElement(lgElement))
            Next lgElement
            
        Else
        'column vector
            'Avoid repeated separators... not likelly on column vectors
            'Do While VBA.InStr(1, strVector, (strRowSeparator & strRowSeparator)) > 0
            '    strVector = VBA.Replace(strVector, strRowSeparator & strRowSeparator, strRowSeparator)
            'Loop
            
            aElement() = VBA.Split(strText, strRowSeparator)
            
            ReDim mVector(g_Base + LBound(aElement) To g_Base + UBound(aElement), g_Base)
            For lgElement = LBound(aElement) To UBound(aElement)
                mVector(lgElement, g_Base) = VBA.Val(aElement(lgElement))
            Next lgElement
        End If

        fNewVector = mVector
    End If
End Function
Public Function fNewVectorStr(ByVal strText As String, _
                              Optional ByVal strColSeparator As String = " ", _
                              Optional ByVal strRowSeparator As String = ";", _
                              Optional ByVal strNewLine As String = "\") As String()
    Dim vArray As Variant
    Dim aStr() As String
    Dim lgC As Long
    Dim lgR As Long
    
    vArray = fNewVector(strText, strColSeparator, strRowSeparator, strNewLine)
    If IsArray(vArray) Then
        If fNdims(vArray) = 1 Then
            ReDim aStr(LBound(vArray, 1) To UBound(vArray, 1))
            For lgR = LBound(vArray, 1) To UBound(vArray, 1)
                aStr(lgR) = VBA.CStr(VBA.Val(vArray(lgR)))
            Next lgR
        
        ElseIf fNdims(vArray) = 2 Then
            ReDim aStr(LBound(vArray, 1) To UBound(vArray, 1), _
                       LBound(vArray, 2) To UBound(vArray, 2))
            For lgR = LBound(vArray, 1) To UBound(vArray, 1)
                For lgC = LBound(vArray, 2) To UBound(vArray, 2)
                    aStr(lgR, lgC) = VBA.CStr(VBA.Val(vArray(lgR, lgC)))
                Next lgC
            Next lgR
        End If
        fNewVectorStr = aStr()
    
        Erase aStr()
    End If
    Erase vArray
End Function
Public Function fNewVectorDbl(ByVal strText As String, _
                              Optional ByVal strColSeparator As String = " ", _
                              Optional ByVal strRowSeparator As String = ";", _
                              Optional ByVal strNewLine As String = "\") As Double()
    Dim vArray As Variant
    Dim aDbl() As Double
    Dim lgC As Long
    Dim lgR As Long
    
    vArray = fNewVector(strText, strColSeparator, strRowSeparator, strNewLine)
    If IsArray(vArray) Then
        If fNdims(vArray) = 1 Then
            ReDim aDbl(LBound(vArray, 1) To UBound(vArray, 1))
            For lgR = LBound(vArray, 1) To UBound(vArray, 1)
                aDbl(lgR) = VBA.CDbl(VBA.Val(vArray(lgR)))
            Next lgR
        
        ElseIf fNdims(vArray) = 2 Then
            ReDim aDbl(LBound(vArray, 1) To UBound(vArray, 1), _
                       LBound(vArray, 2) To UBound(vArray, 2))
            For lgR = LBound(vArray, 1) To UBound(vArray, 1)
                For lgC = LBound(vArray, 2) To UBound(vArray, 2)
                    aDbl(lgR, lgC) = VBA.CDbl(VBA.Val(vArray(lgR, lgC)))
                Next lgC
            Next lgR
        End If
        fNewVectorDbl = aDbl()
    
        Erase aDbl()
    End If
    Erase vArray
End Function
Public Function fNewVectorSng(ByVal strText As String, _
                              Optional ByVal strColSeparator As String = " ", _
                              Optional ByVal strRowSeparator As String = ";", _
                              Optional ByVal strNewLine As String = "\") As Single()
    Dim vArray As Variant
    Dim aSng() As Single
    Dim lgC As Long
    Dim lgR As Long
    
    vArray = fNewVector(strText, strColSeparator, strRowSeparator, strNewLine)
    If IsArray(vArray) Then
        If fNdims(vArray) = 1 Then
            ReDim aSng(LBound(vArray, 1) To UBound(vArray, 1))
            For lgR = LBound(vArray, 1) To UBound(vArray, 1)
                aSng(lgR) = VBA.CSng(VBA.Val(vArray(lgR)))
            Next lgR
        
        ElseIf fNdims(vArray) = 2 Then
            ReDim aSng(LBound(vArray, 1) To UBound(vArray, 1), _
                       LBound(vArray, 2) To UBound(vArray, 2))
            For lgR = LBound(vArray, 1) To UBound(vArray, 1)
                For lgC = LBound(vArray, 2) To UBound(vArray, 2)
                    aSng(lgR, lgC) = VBA.CSng(VBA.Val(vArray(lgR, lgC)))
                Next lgC
            Next lgR
        End If
        fNewVectorSng = aSng()
    
        Erase aSng()
    End If
    Erase vArray
End Function
Public Function fNewVectorLng(ByVal strText As String, _
                              Optional ByVal strColSeparator As String = " ", _
                              Optional ByVal strRowSeparator As String = ";", _
                              Optional ByVal strNewLine As String = "\") As Long()
    Dim vArray As Variant
    Dim aLng() As Long
    Dim lgC As Long
    Dim lgR As Long
    
    vArray = fNewVector(strText, strColSeparator, strRowSeparator, strNewLine)
    If IsArray(vArray) Then
        If fNdims(vArray) = 1 Then
            ReDim aLng(LBound(vArray, 1) To UBound(vArray, 1))
            For lgR = LBound(vArray, 1) To UBound(vArray, 1)
                aLng(lgR) = VBA.CLng(VBA.Val(vArray(lgR)))
            Next lgR
        
        ElseIf fNdims(vArray) = 2 Then
            ReDim aLng(LBound(vArray, 1) To UBound(vArray, 1), _
                       LBound(vArray, 2) To UBound(vArray, 2))
            For lgR = LBound(vArray, 1) To UBound(vArray, 1)
                For lgC = LBound(vArray, 2) To UBound(vArray, 2)
                    aLng(lgR, lgC) = VBA.CLng(VBA.Val(vArray(lgR, lgC)))
                Next lgC
            Next lgR
        End If
        fNewVectorLng = aLng()
    
        Erase aLng()
    End If
    Erase vArray
End Function
Public Function fNewVectorInt(ByVal strText As String, _
                              Optional ByVal strColSeparator As String = " ", _
                              Optional ByVal strRowSeparator As String = ";", _
                              Optional ByVal strNewLine As String = "\") As Integer()
    Dim vArray As Variant
    Dim aInt() As Integer
    Dim lgC As Long
    Dim lgR As Long
    
    vArray = fNewVector(strText, strColSeparator, strRowSeparator, strNewLine)
    If IsArray(vArray) Then
        If fNdims(vArray) = 1 Then
            ReDim aInt(LBound(vArray, 1) To UBound(vArray, 1))
            For lgR = LBound(vArray, 1) To UBound(vArray, 1)
                aInt(lgR) = VBA.CInt(VBA.Val(vArray(lgR)))
            Next lgR
        
        ElseIf fNdims(vArray) = 2 Then
            ReDim aInt(LBound(vArray, 1) To UBound(vArray, 1), _
                       LBound(vArray, 2) To UBound(vArray, 2))
            For lgR = LBound(vArray, 1) To UBound(vArray, 1)
                For lgC = LBound(vArray, 2) To UBound(vArray, 2)
                    aInt(lgR, lgC) = VBA.CInt(VBA.Val(vArray(lgR, lgC)))
                Next lgC
            Next lgR
        End If
        fNewVectorInt = aInt()
    
        Erase aInt()
    End If
    Erase vArray
End Function
Public Function fNewVectorBool(ByVal strText As String, _
                               Optional ByVal strColSeparator As String = " ", _
                               Optional ByVal strRowSeparator As String = ";", _
                               Optional ByVal strNewLine As String = "\") As Boolean()
    Dim vArray As Variant
    Dim aBool() As Boolean
    Dim lgC As Long
    Dim lgR As Long
    
    vArray = fNewVector(strText, strColSeparator, strRowSeparator, strNewLine)
    If IsArray(vArray) Then
        If fNdims(vArray) = 1 Then
            ReDim aBool(LBound(vArray, 1) To UBound(vArray, 1))
            For lgR = LBound(vArray, 1) To UBound(vArray, 1)
                aBool(lgR) = VBA.CBool(VBA.Val(vArray(lgR)))
            Next lgR
        
        ElseIf fNdims(vArray) = 2 Then
            ReDim aBool(LBound(vArray, 1) To UBound(vArray, 1), _
                       LBound(vArray, 2) To UBound(vArray, 2))
            For lgR = LBound(vArray, 1) To UBound(vArray, 1)
                For lgC = LBound(vArray, 2) To UBound(vArray, 2)
                    aBool(lgR, lgC) = VBA.CBool(VBA.Val(vArray(lgR, lgC)))
                Next lgC
            Next lgR
        End If
        fNewVectorBool = aBool()
    
        Erase aBool()
    End If
    Erase vArray
End Function
Public Function fNewVectorByte(ByVal strText As String, _
                               Optional ByVal strColSeparator As String = " ", _
                               Optional ByVal strRowSeparator As String = ";", _
                               Optional ByVal strNewLine As String = "\") As Byte()
    Dim vArray As Variant
    Dim aByte() As Byte
    Dim lgC As Long
    Dim lgR As Long
    
    vArray = fNewVector(strText, strColSeparator, strRowSeparator, strNewLine)
    If IsArray(vArray) Then
        If fNdims(vArray) = 1 Then
            ReDim aByte(LBound(vArray, 1) To UBound(vArray, 1))
            For lgR = LBound(vArray, 1) To UBound(vArray, 1)
                aByte(lgR) = VBA.CByte(VBA.Val(vArray(lgR)))
            Next lgR
        
        ElseIf fNdims(vArray) = 2 Then
            ReDim aByte(LBound(vArray, 1) To UBound(vArray, 1), _
                       LBound(vArray, 2) To UBound(vArray, 2))
            For lgR = LBound(vArray, 1) To UBound(vArray, 1)
                For lgC = LBound(vArray, 2) To UBound(vArray, 2)
                    aByte(lgR, lgC) = VBA.CByte(VBA.Val(vArray(lgR, lgC)))
                Next lgC
            Next lgR
        End If
        fNewVectorByte = aByte()
    
        Erase aByte()
    End If
    Erase vArray
End Function

Public Function fLength(ByRef mArray As Variant) As Long
' length     Length of vector or largest array dimension
    Dim nDim As Long
    Dim lgDim As Long
    
    If IsArray(mArray) Then
        On Error GoTo ExitProc
        lgDim = 0
        Do
            lgDim = lgDim + 1
            If nDim  0)
        Loop
    End If

ExitProc:
    On Error GoTo 0
    fNdims = (lgDim - 1)
End Function

Public Function fNumEl(ByRef mArray As Variant) As Long
' numel      Number of array elements
    Dim lgDim As Long
    Dim lgElements As Long
    
    If IsArray(mArray) Then
        On Error GoTo ExitProc
        lgDim = 0
        Do
            lgDim = lgDim + 1
            lgElements = lgElements * (UBound(mArray, lgDim) - LBound(mArray, lgDim) + 1)
        Loop
    End If

ExitProc:
    On Error GoTo 0
    fNumEl = lgElements
End Function

Public Function IsColumn(ByRef mArray As Variant) As Boolean
' iscolumn   Determines whether input is column vector
    If IsArray(mArray) Then
        IsColumn = (UBound(mArray, 2) - LBound(mArray, 2) = 1)
    End If
End Function

'Public Function IsEmpty(ByRef mArray As Variant) As Boolean
'' isempty    Determines whether array is empty
'    If IsArray(mArray) Then
'        'IsEmpty = True
'    End If
'End Function
'Public Function IsMatrix(ByRef mArray As Variant) As Boolean
'' ismatrix   Determines whether input is matrix
'    If IsArray(mArray) Then
'        'IsMatrix = True
'    End If
'End Function

Public Function IsRow(ByRef mArray As Variant) As Boolean
' isrow      Determines whether input is row vector
    If IsArray(mArray) Then
        IsRow = (UBound(mArray, 1) - LBound(mArray, 1) = 1)
    End If
End Function

Public Function IsScalar(ByRef mArray As Variant) As Boolean
' isscalar   Determines whether input is scalar
    If IsArray(mArray) Then
        IsScalar = (Not IsArray(mArray))
    End If
End Function

Public Function IsVector(ByRef mArray As Variant) As Boolean
' isvector   Determines whether input is vector
    If IsArray(mArray) Then
        IsVector = (UBound(mArray, 1) = LBound(mArray, 1)) Or (UBound(mArray, 2) = LBound(mArray, 2))
    End If
End Function

Public Function fBlkDiag(ByVal mDiagonal As Variant, _
                         Optional ByVal lgDiagonal As Long = 0) As Variant
' blkdiag    Constructs block diagonal matrix from input arguments
'            placing the elements of vector mDiagonal on the lgDiagonal_th diagonal.
'     lgDiagonal=0 represents the main diagonal
'     lgDiagonal>0 is above the main diagonal
'     lgDiagonal<0 is below the main diagonal
    Dim mArray As Variant
    Dim lgElement As Long
    
    If IsArray(mDiagonal) Then
        ReDim mArray(LBound(mDiagonal) To UBound(mDiagonal), LBound(mDiagonal) To UBound(mDiagonal))
        If lgDiagonal = 0 Then
            For lgElement = LBound(mDiagonal) To UBound(mDiagonal)
                mArray(lgElement, lgElement) = mDiagonal(lgElement)
            Next lgElement
        ElseIf lgDiagonal  0 Then
            For lgElement = LBound(mDiagonal) To UBound(mDiagonal)
                mArray(lgElement, lgElement + lgDiagonal) = mDiagonal(lgElement)
            Next lgElement
        End If
        fBlkDiag = mArray
    End If
End Function

Public Function fCircShift(ByRef mArray As Variant, _
                           ByVal mShifter As Variant, _
                           Optional ByVal dimCirculate As Long = 0) As Boolean
' circshift  Shifts array circularly
' Y = circshift(A,K) circularly shifts the elements in array A by K positions.
' If K is an integer, then circshift shifts along the first dimension of A whose size does not equal 1.
' If K is a vector of integers, then each element of K indicates the shift amount in the corresponding dimension of A.
    Dim lgR As Long
    Dim lgC As Long
    Dim lgShift As Long
    Dim mArrayTmp As Variant
    
    If IsArray(mArray) Then
        If dimCirculate = 0 Then
            'Copy array
            mArrayTmp = mArray
            
            If IsArray(mShifter) Then
                For lgR = LBound(mArray, 1) To UBound(mArray, 1)
                    If lgR - mShifter(g_Base + 0)  dbThreshold, mArray(lgR, lgC), dbThreshold)
            Next lgC
        Next lgR
        
        fThreshold = mThreshold
    End If
End Function

Public Function fRound(ByVal mArray As Variant, _
                       Optional ByVal lgDigits As Long = 0) As Variant
    Dim lgR As Long
    Dim lgC As Long
    Dim mRound As Variant

    If IsArray(mArray) Then
        ReDim mThreshold(LBound(mArray, 1) To UBound(mArray, 1), LBound(mArray, 2) To UBound(mArray, 2))
        For lgR = LBound(mArray, 1) To UBound(mArray, 1)
            For lgC = LBound(mArray, 2) To UBound(mArray, 2)
                mRound(lgR, lgC) = VBA.Round(mArray(lgR, lgC), lgDigits)
            Next lgC
        Next lgR
        fRound = mRound
    End If
End Function

Public Function fMagnitude(ByVal mArray As Variant, _
                           Optional ByVal lgOrder As Long = 2) As Double
    Dim lgR As Long
    Dim lgC As Long
    Dim dbMagnitude As Long

    If IsArray(mArray) Then
        For lgR = LBound(mArray, 1) To UBound(mArray, 1)
            For lgC = LBound(mArray, 2) To UBound(mArray, 2)
                dbMagnitude = (mArray(lgR, lgC) * mArray(lgR, lgC))
            Next lgC
        Next lgR
        If lgOrder = 2 Then
            fMagnitude = VBA.Sqr(dbMagnitude)
        Else
            fMagnitude = dbMagnitude ^ (1 / lgOrder)
        End If
    End If
End Function

Also, the Gauss-Jordan reduction method is coded as:

Option Explicit

Dim mArray() As Double

Private Sub UserForm_Initialize()
    'call sSolve
End Sub

Private Sub cbSolve_Click()
    Call sSolve
End Sub

Private Sub sSolve()
    Call sArray_Load
    Call sGaussJordan(mArray())
End Sub

Private Sub sArray_Load()
    On Error GoTo ErrLec
    
    Dim lgR As Long
    Dim lgC As Long
    Dim lgRetVal As Long
    Dim Nm As Long
    
    If VarType(Selection) = vbObject Then
        mArray() = fNewArrayDbl(Me.txtSystem.Text, " ", ";", "\")
        Me.sbNum.Value = UBound(mArray, 1) - LBound(mArray, 1) + 1
        Nm = Me.sbNum.Value
    Else
        If Selection.Rows.Count > 1 And _
           Selection.Rows.Count > 1 Then
            Me.sbNum.Value = Selection.Rows.Count
            Nm = Me.sbNum.Value
            
            ReDim mArray(g_Base To (Nm - 1 + g_Base), g_Base To Nm + g_Base)
            For lgR = g_Base To Nm - 1 + g_Base
                For lgC = g_Base To Nm + g_Base
                    'If Cuadric.TextMatrix(lgR + 1, lgC) = "" Then Cuadric.TextMatrix(lgR + 1, lgC) = 0
                    'mArray(lgR, lgC) = Cuadric.TextMatrix(lgR + 1, lgC)
                    mArray(lgR, lgC) = Selection.Cells(lgR + 1, lgC + 1).Value2
                Next
            Next
        Else
            mArray() = fNewArrayDbl(Me.txtSystem.Text, " ", ";", "\")
            Me.sbNum.Value = UBound(mArray, 1) - LBound(mArray, 1) + 1
            Nm = Me.sbNum.Value
        End If
    End If
    
ExitProc:
    Exit Sub

ErrLec:
    lgRetVal = VBA.MsgBox("Error introducing data (" & Err.Description & ")", vbExclamation)
End Sub

Private Sub sbNum_Change()
    txtEquations.Value = VBA.Str(sbNum.Value)
End Sub

Public Sub sGaussJordan(ByRef mArray() As Double)
'Based on code found: http://mvb6.blogspot.com/2017/08/metodo-de-gauss-jordan-vb-60.html
    Dim lgR As Long
    Dim lgC As Long
    Dim lgPivot As Long
    Dim lgR_Homogenize As Long
    Dim dbTmp As Double
    Dim lgRetVal As Long
    Dim mArrayTmp() As Double
    Dim Nm As Integer
    
    On Error GoTo ErrControl
    
    Nm = UBound(mArray, 1) - LBound(mArray, 1) + 1
    ReDim mArrayTmp(LBound(mArray, 1) To UBound(mArray, 1), LBound(mArray, 2) To UBound(mArray, 2))
    
    ' Swap rows (if needed)
    If (mArray(0, 0) = 0) Then
        For lgR = LBound(mArray, 1) To UBound(mArray, 1)
            If (mArray(lgR, 0)  0) Then
                For lgC = LBound(mArray, 2) To UBound(mArray, 2)
                    mArrayTmp(0, lgC) = mArray(0, lgC)
                    mArray(0, lgC) = mArray(lgR, lgC)
                    mArray(lgR, lgC) = mArrayTmp(0, lgC)
                Next lgC
            End If
        Next lgR
    End If
    
    For lgPivot = LBound(mArray, 1) To UBound(mArray, 1)
        dbTmp = mArray(lgPivot, lgPivot)
        For lgC = LBound(mArray, 2) To UBound(mArray, 2)
            mArray(lgPivot, lgC) = mArray(lgPivot, lgC) / dbTmp
        Next lgC
        For lgR = LBound(mArray, 1) To UBound(mArray, 1)
            If (lgR = lgPivot) Then GoTo Es
            dbTmp = mArray(lgR, lgPivot)
            For lgR_Homogenize = LBound(mArray, 2) To UBound(mArray, 2)
                mArray(lgR, lgR_Homogenize) = mArray(lgR, lgR_Homogenize) - (dbTmp * mArray(lgPivot, lgR_Homogenize))
            Next lgR_Homogenize
Es:
        Next lgR
    Next lgPivot
    
    'Print solution
    For lgR = LBound(mArray, 1) To UBound(mArray, 1)
        Debug.Print mArray(lgR, Nm) 'vba.Format(mArray(lgR, Nm), "##,##0.00")
    Next lgR
    
ExitProc:
    Exit Sub

ErrControl:
    lgRetVal = VBA.MsgBox("System has no solution", vbCritical)
End Sub

Future implementations will be, for example, then capability to handle complex numbers, via the UDT tObject, with little to no change in the code (only replacing “) As Variant” with “) As tObject()” and ” As Variant” with “() As tObject”. Even NaN, NaT, Inf,… MatLab special reserved variables can be used along the code, setting TypeObj to 0 and giving .Text property the name of the reserved variable.

This will be a possible group implementation to handle complex numbers inside VBA

Option Explicit

Public Enum eTypeObj
    eText = 0
    eNatural = 2
    eReal = 1
    eComplex = -1
End Enum
Public Type tObject
    Size As Long 'Total bytes
    
    TypeObj As Long
        'Text = 0
        '[R]Real = 1, [C]Complex = -1
        '[Z]Natural (Integers ±) = 2
    
    R As Double 'Real part
    I As Double 'Imaginary part
    
    Text As String
    'Name As String * 10
End Type

Public Function fNew(Optional ByVal TypeObj As Long = 0, _
                     Optional ByVal R As Double = 0, _
                     Optional ByVal c As Double = 0, _
                     Optional ByVal Text As String = "") As tObject
'Set new object
    With fNew
        .Size = 20 + Len(Text)
        .TypeObj = TypeObj '[Z]Natural = 2, [R]Real = 1, [C]Complex = -1, Text = 0
        
        .R = R
        .I = c
        
        .Text = Text
    End With
End Function
Public Function fComplex(ByRef dbReal As Double, _
                         ByRef dbImaginary As Double) As tObject
' complex   Create complex array
    fComplex = fNew(eComplex, dbReal, dbImaginary, "")
End Function
Public Function fAbs(ByRef oObject As tObject) As Double
' abs       Absolute value and complex magnitude
    With oObject
        If .TypeObj > 0 Then
            fAbs = VBA.Abs(.R)
        ElseIf .TypeObj = eComplex Then
            fAbs = VBA.Sqr(.R ^ 2 + .I ^ 2)
        End If
    End With
End Function
Public Function fAngle(ByRef oObject As tObject) As Double
' angle     Phase angle
    With oObject
        If VBA.Abs(.R)  0 Then
            fSignObj = fSign(oObject.R)
        ElseIf .TypeObj = eComplex Then
            fSignObj = fSign(oObject.R)
        End If
    End With
End Function
Public Function fUnwrap(ByRef oObject1 As tObject, _
                        ByRef oObject2 As tObject) As Double
' unwrap    Correct phase angles to produce smoother phase plots
'!!!!!
End Function
Public Function fReal(ByRef oObject As tObject) As Double
' real      Real part of complex number
    If oObject.TypeObj = eComplex Then fReal = oObject.R
End Function
Public Function fImag(ByRef oObject As tObject) As Double
' imag      Imaginary part of complex number
    If oObject.TypeObj = eComplex Then fImag = oObject.I
End Function

Public Function fComplexSum(ByRef oObject1 As tObject, _
                            ByRef oObject2 As tObject) As tObject
    If (VBA.Abs(oObject1.TypeObj) = eReal Or VBA.Abs(oObject2.TypeObj) = eReal) Then
        With fComplexSum
            .R = oObject1.R + oObject2.R
            If (oObject1.TypeObj = eComplex Or oObject2.TypeObj = eComplex) Then
                .TypeObj = eComplex
                .I = oObject1.I + oObject2.I
            Else
                .TypeObj = eReal
            End If
        End With
    End If
End Function

Public Function fComplexDiff(ByRef oObject1 As tObject, _
                             ByRef oObject2 As tObject) As tObject
    If (VBA.Abs(oObject1.TypeObj) = eReal Or VBA.Abs(oObject2.TypeObj) = eReal) Then
        With fComplexDiff
            .R = oObject1.R - oObject2.R
            If (oObject1.TypeObj = eComplex Or oObject2.TypeObj = eComplex) Then
                .TypeObj = eComplex
                .I = oObject1.I - oObject2.I
            Else
                .TypeObj = eReal
            End If
        End With
    End If
End Function

Public Function fComplexMult(ByRef oObject1 As tObject, _
                             ByRef oObject2 As tObject) As tObject
' z1·z2 = (a, b)·(c, d) = (a·c - b·d), (a·d - b·c)
    If (VBA.Abs(oObject1.TypeObj) = eReal Or VBA.Abs(oObject2.TypeObj) = eReal) Then
        With fComplexMult
            .R = oObject1.R * oObject2.R 'only the real part
            If (oObject1.TypeObj = eComplex Or oObject2.TypeObj = eComplex) Then
                .TypeObj = eComplex
                .I = oObject1.R * oObject2.I + oObject1.I * oObject2.R
                .R = .R - oObject1.I * oObject2.I
            Else
                .TypeObj = eReal
            End If
        End With
    End If
End Function

Public Function fComplexRec(ByRef oObject As tObject) As tObject
' 1/z = 1/(a, b) = (a, -b)/(a²+b²)
    Dim oReciproc As tObject
    Dim dbModule² As Double
    
    With oObject
        If .TypeObj = eComplex Then
            dbModule² = (.R ^ 2 + .I ^ 2)
            With fComplexRec
                .TypeObj = oObject.TypeObj
                .R = oObject.R / dbModule²
                .I = -oObject.I / dbModule²
            End With
        
        ElseIf .TypeObj = eReal Then
            With fComplexRec
                .TypeObj = oObject.TypeObj
                .R = oObject.R
            End With
        End If
    End With
End Function

Private Sub sComplexDiv()
    Dim oObject1 As tObject
    Dim oObject2 As tObject
    Dim oObject As tObject
    With oObject1
        .TypeObj = eComplex
        .R = 4
        .I = 3
    End With
    With oObject2
        .TypeObj = eComplex
        .R = 2
        .I = 1
    End With
    oObject = fComplexDiv(oObject1, oObject2)
Stop
End Sub

Public Function fComplexDiv(ByRef oObject1 As tObject, _
                            ByRef oObject2 As tObject) As tObject
' z1/z2 = (a, b)·[(c, d)/(c²+d²)] = (ac+bd , cb-da)/(c²+d²)
    'Dim oComplexRec As tObject
    Dim dbModule² As Double
    
    If (VBA.Abs(oObject1.TypeObj) = eReal Or VBA.Abs(oObject2.TypeObj) = eReal) Then
        With fComplexDiv
            If (oObject2.TypeObj = eComplex) Then
                dbModule² = (oObject2.R ^ 2 + oObject2.I ^ 2)
                .TypeObj = eComplex
                'oComplexRec = fComplexRec(oObject2)
                .R = (oObject1.R * oObject2.R + oObject1.I * oObject2.I) / dbModule²
                .I = (oObject1.I * oObject2.R - oObject1.R * oObject2.I) / dbModule²
            
            Else
                .TypeObj = eReal
                .R = oObject1.R / oObject2.R
                .I = oObject1.R / oObject2.R
            End If
        End With
    End If
End Function

Public Function fConj(ByRef oObject As tObject) As tObject
' conj      Complex conjugate
    With fConj
        If .TypeObj = eComplex Then
            .TypeObj = oObject.TypeObj
            .R = oObject.R
            .I = -oObject.I
        
        ElseIf .TypeObj = eReal Then
            .TypeObj = oObject.TypeObj
            .R = oObject.R
        End If
    End With
End Function

Leave a Reply

Your email address will not be published. Required fields are marked *