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
Aside from loading an image on a picture object, any image (supported formats “*.bmp;*.jpg;*.jpeg;*.gif”) can be represented in cells, like in ASCII art or colouring cells interior.
For ASCII art, from 16M color (long) it should be reduced to 256 gray scale color, and finally converted to a 16 text scale (using in decreasing darkness the following characters: M # @ H X $ % + / ; : = – , .).
It would be better if used a four reduced scale with Unicode symbols (9617 9618 9619 and 160 for whitest)
Following code achieves both, colouring interior functionality is deactivated in code because it’s very sloooooow.
Processing of aerial imagery is resource demanding and will require some serious hardware. Online services are therefore pay-as-you-go or tied to a license.
Or figure a random set of points inside a vertical oriented ellipse (there is also some code to draw the ellipse perimeter).
This kind of data set may never get a chance to be fitted if looking for vertical distance minimization.
To solve this I’ve come to this code that solves the lack of criteria. It still can not do anything against three of the