Remove the first element of a VBA array - arrays

Is there a way to remove the first element of an array in VBA?
Something like javascript shift() method?
Option Explicit
Sub Macro1()

There is no direct method in VBA but you can remove the first element easily like this:
'Your existing code
'...
'Remove "ReDim Preserve matriz(1 To UBound(matriz))"
For i = 1 To UBound(matriz)
matriz(i - 1) = matriz(i)
Next i
ReDim Preserve matriz(UBound(matriz) - 1)

There is unfortunately not. You have to write a method to do it. One good example is http://www.vbforums.com/showthread.php?562928-Remove-Item-from-an-array
'~~> Remove an item from an array, then resize the array
Public Sub DeleteArrayItem(ItemArray As Variant, ByVal ItemElement As Long)
Dim i As Long
If Not IsArray(ItemArray) Then
Err.Raise 13, , "Type Mismatch"
Exit Sub
End If
If ItemElement < LBound(ItemArray) Or ItemElement > UBound(ItemArray) Then
Err.Raise 9, , "Subscript out of Range"
Exit Sub
End If
For i = ItemElement To lTop - 1
ItemArray(i) = ItemArray(i + 1)
Next
On Error GoTo ErrorHandler:
ReDim Preserve ItemArray(LBound(ItemArray) To UBound(ItemArray) - 1)
Exit Sub
ErrorHandler:
'~~> An error will occur if array is fixed
Err.Raise Err.Number, , _
"Array not resizable."
End Sub

If you have a string array, you could join, offset, and split again.
Public Sub test()
Dim vaSplit As Variant
Dim sTemp As String
Const sDEL As String = "||"
vaSplit = Split("1 2 3 4", Space(1))
sTemp = Join(vaSplit, sDEL)
vaSplit = Split(Mid$(sTemp, InStr(1, sTemp, sDEL) + Len(sDEL), Len(sTemp)), sDEL)
Debug.Print Join(vaSplit, vbNewLine)
End Sub
Returns
2
3
4

Not an answer but a study on array addressing.
This code:
ReDim Preserve matriz(1)
matriz(1) = 5
Creates an array with two elements: 0 and 1
UBound() returns 1
Here is some code that may help explore the issue:
Option Explicit
Sub Macro1()
Dim matriz() As Variant
Dim x As Variant
Dim i As Integer
matriz = Array(0)
ReDim Preserve matriz(1)
matriz(1) = 5
ReDim Preserve matriz(2)
matriz(2) = 10
ReDim Preserve matriz(3)
matriz(3) = 4
Debug.Print "Initial For Each"
For Each x In matriz
Debug.Print ":" & x
Next x
Debug.Print "Initial For i = 0"
For i = 0 To UBound(matriz)
Debug.Print ":" & matriz(i)
Next i
Debug.Print "Initial For i = 1"
For i = 1 To UBound(matriz)
Debug.Print ":" & matriz(i)
Next i
Debug.Print "remove one"
For i = 1 To UBound(matriz)
matriz(i - 1) = matriz(i)
Next i
ReDim Preserve matriz(UBound(matriz) - 1)
For Each x In matriz
Debug.Print ":" & x
Next x
Debug.Print "remove one more"
For i = 1 To UBound(matriz)
matriz(i - 1) = matriz(i)
Next i
ReDim Preserve matriz(UBound(matriz) - 1)
For Each x In matriz
Debug.Print ":" & x
Next x
End Sub
Out:
Initial For Each
:0
:5
:10
:4
Initial For i = 0
:0
:5
:10
:4
Initial For i = 1
:5
:10
:4
remove one
:5
:10
:4
remove one more
:10
:4

No direct method, but sort of work around without loops :-)
This approach uses an intermediate target range to
[1] receive the array data (starting e.g. in cell A10) and
.... get them back as resized 2-dim datafield (counting from cell A11 thus omitting the first element) and
[2] transpose it back to a flat 1-dim array
Example code
Option Explicit
Sub Macro1()
'Method: use temporary target range to restructure array
Dim matriz() As Variant
Dim rng As Range
'[0.1] Assign same data set to array as in original post
matriz = Array(0, 5, 10, 4)
Debug.Print "a) original matriz(" & LBound(matriz) & " To " & UBound(matriz) & ")", Join(matriz, ", ")
'instead of:
' ReDim Preserve matriz(0 To 3)
' matriz(0) = 0: matriz(1) = 5: matriz(2) = 10: matriz(3) = 4
'[0.2] Set temporary range to memory
Set rng = ThisWorkbook.Worksheets("Tabelle1").Range("A10").Resize(UBound(matriz) + 1, 1)
'[1] Write array data to range and reassign to matriz cutting first row
rng = Application.Transpose(matriz) ' fill in array data (transposed to column)
matriz = rng.Offset(1, 0).Resize(UBound(matriz), 1) ' assign data to (2-dim) array omitting first row
'[2] Transpose back to flat 1-dim array
matriz = Application.Transpose(Application.Index(matriz, 0, 1))
Debug.Print "b) ~~> new matriz(" & LBound(matriz) & " To " & UBound(matriz) & ")", Join(matriz, ", "),
End Sub
Example output in VBE's immediate window (Debug.Print)
a) original matriz(0 To 3) 0, 5, 10, 4
b) ~~> new matriz(1 To 3) 5, 10, 4
//Edit #1 Tricky alternative using combobox properties & methods
Sub RemoveFirstElement()
'a) Assign same data set to array as in original post
Dim matriz() As Variant
matriz = Array(0, 5, 10, 4)
Debug.Print "a) original matriz (" & LBound(matriz) & " To " & UBound(matriz) & ")", Join(matriz, ", ")
'b) Remove first element in matriz (note 0-based indices!)
RemoveElem matriz, 0 ' << call help procedure RemoveElem
Debug.Print "b) ~~> new matriz (" & LBound(matriz) & " To " & UBound(matriz) & ")", Join(matriz, ", ")
End Sub
Help procedure RemoveElem
This help procedure profits from the integrated method .RemoveItem of a combobox control which you can get on the fly without need to create an extra userform *)
Sub RemoveElem(arr, ByVal elemIndex As Long)
'Use combobox properties and methods on the fly (without need to create form)
With CreateObject("Forms.ComboBox.1")
'a) assign existing values
.List = Application.Transpose(arr)
'b) delete e.g. 1st element (0-based control indices!)
.RemoveItem elemIndex
'c) assign modified values to tmp array (losing 2nd dimension by transposition)
Dim tmp As Variant
tmp = Application.Transpose(.List)
'd) decrement base by 1 (from 1 to 0) - optional
ReDim Preserve tmp(0 To UBound(tmp) - 1)
'e) overwrite original array
arr = tmp
End With
End Sub
Example output in VBE's immediate window (Debug.Print)
a) original matriz(0 To 3) 0, 5, 10, 4
b) ~~> new matriz(1 To 3) 5, 10, 4
Related links
Can I return a 0-based array from ws.UsedRange?
*) I found the way to create a solo combobox at Create an empty 2d-array )

What follows is a function "Shift", which behaves like the shift method in JS, and an example of the use of "Shift"
Sub tryShift()
Dim aRy As Variant, sT As Variant
aRy = Array("one", "two", "three", "four")
Debug.Print "Original array:"
For Each sT In aRy
Debug.Print sT
Next
aRy = Shift(aRy)
Debug.Print vbCrLf & "Array having been " & Chr(34) & "shifted" & Chr(34) & ":"
For Each sT In aRy
Debug.Print sT
Next
End Sub
Function Shift(aRy As Variant)
Dim iCt As Integer, iUbd As Integer
iCt = 0
iUbd = UBound(aRy)
Do While iCt < iUbd
aRy(iCt) = aRy(iCt + 1)
iCt = iCt + 1
Loop
ReDim Preserve aRy(UBound(aRy) - 1)
Shift = aRy
End Function
Output:
Original array:
one
two
three
four
Array having been "shifted":
two
three
four

Related

How to get array value using coordinates in other array?

I'm looking to access an array using coordinates from a different array, like such. This for a situation where I don't on forehand know the number of dimensions in the data array, so can't really just use an undetermined number of optional variables in a function.
Dim myArray(1 To 4, 1 To 2) As String
Dim myCoord(1 To 2) As Long
myArray(1, 1) = "one_one"
myArray(1, 2) = "one_two"
...
myArray(4, 2) = "four_two"
myCoord(1) = 3
myCoord(2) = 1
MsgBox(myArray(myCoord))
So I'm looking for something like the above messagebox being able to display "three_one". Like in python's my_multidim_list[*[i, j, ..., n]] No idea if it's at all possible in VBA, but well, doesn't seem illogical to me to implement such a possibility.
This was my original answer which provides some background on VBA arrays. I will be expanding it to provide enough background to understand my second answer.
The simple answer is:
Dim myArray(1 To 4, 1 To 2) As String
Dim myCoord(1 To 2) As Long
myArray(1, 1) = "one_one"
myArray(1, 2) = "one_two"
...
myArray(4, 2) = "four_two"
myCoord(1) = 3
myCoord(2) = 1
MsgBox(myArray(myCoord(1), myCoord(2))) ' This is the only change
This is based on each element of myCoord defining the element number of the corresponding dimension of myArray.
Extra information about arrays
When you write Dim myArray(1 To 4, 1 To 2) As String, the number of dimensions and the number of elements in each dimension are fixed until you rewrite this statement with different numbers.
If you write Dim myArray() As String, you are declaring the array but the number of dimensions and their bounds will be defined at run time.
Within your code you can write ReDim myArray(a To b, c To d, e To f) where a to f are integer expressions. In most languages I know, the lower bound is defined by the language as 0 or perhaps 1. With VBA, the lower bound can be anything providing the lower bound is not more than the upper bound. I have only once found a use for a negative lower bound but the option is there.
Later you can write ReDim myArray(g To h) but you will lose all the data within myArray.
Alternatively, you can write ReDim Preserve myArray(a To b, c To d, e To g). Note that a to e are unchanged. With ReDim Preserve only the upper bound of the last dimension can be changed. ReDim Preserve creates a new larger (or smaller) array, copies data from the old array and initialises the new elements to the default value for the data type. Over use of ReDim Preserve can slow your macro down to a crawl because the interpreter runs out of memory but if used carefully it can be very useful.
I would probably define myCoords with the same number of dimensions as myArray but that depends on your objective.
There is a lot more I could say about VBA arrays. If you expand on your objectives I will add appropriate extra information.
My answer has exceeded Stackoverflow's limit of 30,000 characters so I have split it into parts. This is part 2.
This block of code is my test routines. I recommend you try them. If nothing else, they demonstrates how to use the class’s methods.
Option Explicit
Sub Test1()
Dim MyArray1 As New MultDimStrArray
Dim MyArray2 As MultDimStrArray
Dim MyArray3 As MultDimStrArray
Dim Bounds1 As Variant
Dim Bounds2() As String
Set MyArray2 = New MultDimStrArray
Set MyArray3 = New MultDimStrArray
Bounds1 = Array("3 To 10", "2", 5)
ReDim Bounds2(1 To 3)
Bounds2(1) = "3 to 10"
Bounds2(2) = "2"
Bounds2(3) = "5"
' Error-free calls
Call MyArray1.Initialise("3 to 10", "2")
Call MyArray1.OutDiag
Call MyArray2.Initialise(Bounds1)
Call MyArray2.OutDiag
Call MyArray3.Initialise(Bounds2)
Call MyArray3.OutDiag
Call MyArray1.Initialise("3 to 10", 2)
Call MyArray1.OutDiag
Call MyArray1.Initialise(2, "-5 to -2")
Call MyArray1.OutDiag
' Calls that end in an error
Call MyArray1.Initialise("3 to 10", "a")
Call MyArray1.OutDiag
Call MyArray1.Initialise("3 to 2")
Call MyArray1.OutDiag
Call MyArray1.Initialise("2to3")
Call MyArray1.OutDiag
Call MyArray1.Initialise(0)
Call MyArray1.OutDiag
Call MyArray1.Initialise(1.5)
Call MyArray1.OutDiag
Call MyArray1.Initialise("2 to ")
Call MyArray1.OutDiag
Call MyArray1.Initialise(" to 2")
Call MyArray1.OutDiag
End Sub
Sub Test2()
Dim InxD1 As Long
Dim InxD2 As Long
Dim InxD3 As Long
Dim MyArray As New MultDimStrArray
Dim Start As Variant
Dim ValueCrnt As String
Dim Values() As String
Call MyArray.Initialise("3 to 5", 3)
Call MyArray.PutElements(Array(3, 1), _
Array("Three-One", "Three-Two", "Three-Three", _
"Four-One", "Four-Two", "Four-Three", _
"Five-One", "Five-Two", "Five-Three"))
Call MyArray.OutDiag
ReDim Values(0 To 0)
For InxD1 = 3 To 5
For InxD2 = 1 To 3
Start = Array(InxD1, InxD2)
Values(0) = InxD1 & "." & InxD2
Call MyArray.PutElements(Start, Values)
Next
Next
Call MyArray.OutDiag
For InxD1 = 3 To 5
For InxD2 = 1 To 3
Start = Array(InxD1, InxD2)
ValueCrnt = InxD1 & "-" & InxD2
Call MyArray.PutElements(Start, ValueCrnt)
Next
Next
Call MyArray.OutDiag
Call MyArray.Initialise("5 to 10", 3, "-3 to 4")
Debug.Print
ReDim Values(-3 To 4)
For InxD1 = 10 To 5 Step -1
For InxD2 = 1 To 3
Start = Array(InxD1, InxD2, -3)
For InxD3 = -3 To 4
Values(InxD3) = InxD1 & "." & InxD2 & "." & InxD3
Next
Call MyArray.PutElements(Start, Values)
Next
Next
Call MyArray.OutDiag
End Sub
Sub Test3()
Dim InxD1 As Long
Dim InxD2 As Long
Dim InxV As Long
Dim MyArray As New MultDimStrArray
Dim Start As Variant
Dim ValueCrnt As String
Dim Values() As String
Call MyArray.Initialise("3 to 5", 3)
Call MyArray.PutElements(Array(3, 1), _
Array("Three-One", "Three-Two", "Three-Three", _
"Four-One", "Four-Two", "Four-Three", _
"Five-One", "Five-Two", "Five-Three"))
Call MyArray.OutDiag
ReDim Values(1 To 9)
Call MyArray.GetElements(Array(3, 1), Values)
Debug.Print
For InxV = LBound(Values) To UBound(Values)
Debug.Print """" & Values(InxV) & """ ";
Next
Debug.Print
ReDim Values(1 To 3)
Debug.Print
For InxD1 = 3 To 5
Call MyArray.GetElements(Array(InxD1, 1), Values)
For InxV = LBound(Values) To UBound(Values)
Debug.Print """" & Values(InxV) & """ ";
Next
Debug.Print
Next
ReDim Values(1 To 4)
For InxV = LBound(Values) To UBound(Values)
Values(InxV) = "Unchanged"
Next
Call MyArray.GetElements(Array(5, 1), Values)
Debug.Print
For InxV = LBound(Values) To UBound(Values)
Debug.Print """" & Values(InxV) & """ ";
Next
Debug.Print
Debug.Print
For InxD1 = 3 To 5
For InxD2 = 1 To 3
Call MyArray.GetElements(Array(InxD1, InxD2), ValueCrnt)
Debug.Print "(" & InxD1 & ", " & InxD2 & ") contains " & ValueCrnt
Next
Next
End Sub
Over the years, I have created subroutines and functions that perform useful tasks not provided by Excel’s standard subroutines and functions. I use PERSONAL.XLSB as a library to hold all these macros. This is one of those functions which is used by OutDiag.
Option Explicit
Public Function PadR(ByVal Str As String, ByVal PadLen As Long, _
Optional ByVal PadChr As String = " ") As String
' Pad Str with trailing PadChr to give a total length of PadLen
' If the length of Str exceeds PadLen, Str will not be truncated
' Nov15 Coded
' 15Sep16 Added PadChr so could pad with characters other than space
If Len(Str) >= PadLen Then
' Do not truncate over length strings
PadR = Str
Else
PadR = Left$(Str & String(PadLen, PadChr), PadLen)
End If
End Function
My answer has exceeded Stackoverflow's limit of 30,000 characters so I have split it into parts. This is part 1.
Although you did not answer my question about how you intended to fill the array, I decided there was only one viable approach which I have implemented as a class.
If you had asked me a couple of months ago about VBA classes, I would have been dismissive. My view was that if your requirement was complex enough to need a class, VBA was not an appropriate language. I have not totally changed by mind but I recently discovered a VBA StringBuilder class which I found very convenient. Building on that experience, I decided to create a class to address your requirement which showed me how easily a class can hide complex processing from the user.
I have named my class MultDimStrArray. If you do not like this name, change it to something you prefer. If you try my test macros, you will have change the name throughout their module.
My class has no public properties. It has four public methods: Initialise, PutElements, GetElements and OutDiag.
Initalise records the number and bounds of the dimensions. Example calls are:
Dim MyArray1 As New MultDimStrArray
Call MyArray1.Initialise("3 to 10", "2")
and
Dim MyArray2 As MultDimStrArray
Dim Bounds1 As Variant
Bounds1 = Array( ("3 to 10", "2")
Call MyArray1.Initialise(Bounds1)
That is, you can create a multi-dimensional string array using:
Dim MyArray1 As New MultDimStrArray
or
Dim MyArray2 As MultDimStrArray
Set MyArray2 = New MultDimStrArray
The first method is more popular but apparently the second is more efficient.
You can record the bounds of the dimensions in the call of Initialise or in a predefined array. I have used the function Array to load the array. You can load an array in the conventional way if you prefer. All three techniques are demonstrated in macro Test1
Once the MDS array has been initialised, you use PutElements to place values within it. The format of the call is:
Call MyArray.PutElements(Start, Values)
Start is an array with one element per dimension in MyArray; it identifies an element within MyArray. Values can be a single variable or an array of any type providing its elements can be converted to strings. If Values is a single variable or an array of length one, its content will be copied to the element identified by Start. If Values is an array of length greater than one, its contents are copied to MyArray starting at Start. A call of PutElements can place a single value in MyArray or can fill the entire array or anything in between. Macro Test2 shows a variety of ways that PutElements can be used.
GetElements is used to extract a value or values from MyArray. The format of the call is as for PutElement and the parameters are the same; only the direction of the copy is different.
The final method is OutDiag which has no parameters. It output full details of MyArray to the Immediate Window. The Immediate Window can hold up to about 200 rows. I considered output to a text file. If you need this routine and you have large volumes of data, I can amend it for file output.
I have tested the methods but not exhaustively. I believe I have created something that will meet your needs. However, I did not wish to spend more time testing it before confirming it does meet your needs particularly as your real data may different significantly from anything I might create.
Do not look at the class yet other than to look at the how-to-use documentation at the top of each method. Try macros Test1, Test2 and Test3. Adapt them to better match your requirements. Try some real data. I have left my original answer at the end of this answer but you will need more background on VBA arrays to understand the code within the class. I will expand my original answer as my next task.
This block of code is the class. It must be placed in a Class Module named MultDimStrArray. I have left my diagnostic code but have commented most of it out. If you encounter errors, report them to me since I do not think you have the knowledge to debug the class yourself.
Option Explicit
' Members
Private MDSArray() As String ' The MD array is held as a 1D array
' Elements are held in the sequence:
' 1D 2D 3D 4D ... nD
' lb lb lb lb lb to ub
' lb lb lb lb+1 lb to ub
' lb lb lb lb+2 lb to ub
' : : : : :
' lb lb lb ub lb to ub
' lb lb lb+1 lb lb to ub
' : : : : :
' ub ub ub ub lb to ub
' Note: each dimension has its own lower and upper bound
Private DimMax As Long ' Number of dimensions
Private DimOffs() As Long ' Offset from element to equivalent element in next
' repeat for each dimension.
' For dimension 1, this is offset from (a,b,c,d) to (a+1,b,c,d).
' For dimension 2, this is offset from (a,b,c,d) to (a,b+1,c,d).
' And so on.
' Used to convert (a,b,c,d) to index into MDSArray.
Private InxMax As Long ' The total number of elements in the MDS array
Private LBounds() As Long ' Lower bound of each dimension
Private UBounds() As Long ' Upper bound of each dimension
' Methods
Public Sub Class_Initialize()
' Will be called by interpreter when it wishes to initialise an instance of
' MultDimStrArray. Setting NumDim = 0 indicates that the instance has not
' be initialised by the class.
DimMax = 0
End Sub
Public Sub GetElements(ParamArray Params() As Variant)
' Extracts one or more strings starting at a specified element from
' the multi-dimensional string array.
' This sub has two compulsory parameters. The declaration uses a ParamArray
' to allow maximum flexibility in the type of those parameters. Effectively,
' this sub has a declaration of:
' GetElements(ByRef Start() As xxxx, ByRef Values() as yyyy) or
' GetElements(ByRef Start() As xxxx, ByVal Values as yyyy) or
' where xxxx can be any of the integer types plus Variant or String.
' and yyyy can be any type that can be accept a string.
' Start is a one-dimensional array with DimMax, integer elements. If the
' type of the array is Variant or String, the element values must be integer
' or an integer held as a string. The bounds of the array are not important.
' A lower bound of one to match dimension one may be convenient but a lower
' bound of zero or some other value may be used if wished.
' If the MDS array has N dimensions, Start must contain N values each of
' which must be within the bounds for the corresponding dimension. Together,
' the values within Start specify an element with the MDS array.
' Values can be a String or Varient variable or a one-dimensional String or
' Varient array. If the values within the MDS array are known to be
' integer, real or Boolean, then other types. However, if a value within
' the MDS array is not as expected, a call of GetElements may result in a
' fatal, VBA error.
' If Values is a variable or an array with a length of one, the value of
' element Start of the MDS array will be copied to Values.
' If Values is an array with a length greater than one, values will be
' copied to it from the MDS array starting from element Start. If possible,
' array Values will be filled; however, if there are insufficient elements
' in the MDS array, the remaining elements of Values will be left unchanged.
'Debug.Print "GetElements"
If DimMax = 0 Then
Debug.Assert False 'Not initialised
Exit Sub
End If
Dim InxA As Long
Dim InxS As Long
Dim InxV As Long
Dim LB As Long
Dim Start() As Long
Dim UB As Long
LB = LBound(Params)
UB = UBound(Params)
If LB + 1 <> UB Then
Debug.Assert False ' There must be exactly two parameters
Exit Sub
End If
If VarType(Params(LB)) < vbArray Then
Debug.Assert False ' First parameter (Start) must be an array
Exit Sub
End If
' Params(Params(LB)) contains values for Start.
InxS = 1
If UBound(Params(LB)) - LBound(Params(LB)) + 1 <> DimMax Then
Debug.Assert False ' Start must have one entry per dimension
Exit Sub
End If
ReDim Start(1 To DimMax)
For InxV = LBound(Params(LB)) To UBound(Params(LB))
' An error here indicates a value that cannot be converted to a Long
Start(InxS) = Params(LB)(InxV)
If Start(InxS) < LBounds(InxS) Or Start(InxS) > UBounds(InxS) Then
Debug.Assert False ' Index is outside range for dimension
Exit Sub
End If
InxS = InxS + 1
Next
InxA = 1
For InxS = 1 To DimMax
InxA = InxA + (Start(InxS) - LBounds(InxS)) * DimOffs(InxS)
Next
'' Report conversion from coordinates to InxA
'Debug.Print "(";
'For InxS = 1 To DimMax - 1
' Debug.Print Start(InxS) & ", ";
'Next
'Debug.Print Start(DimMax) & ") -> " & InxA
If VarType(Params(UB)) < vbArray Then
' Single value to be extracted from element defined by Start
'Debug.Assert False
' An error here indicates Params(UB) cannot hold the value in the MDS array
Params(UB) = MDSArray(InxA)
Else
' Array of values to be extracted starting at element defined by Start
'Debug.Assert False
'Debug.Print "Params(UB) Bounds: " & LBound(Params(UB)) & " To " & UBound(Params(UB))
For InxV = LBound(Params(UB)) To UBound(Params(UB))
Params(UB)(InxV) = MDSArray(InxA)
'Debug.Print "(" & InxA & ") contains " & Params(UB)(InxV)
InxA = InxA + 1
If InxA > InxMax Then
' Have reached end of MDSArray
Exit For
End If
Next
End If
End Sub
Public Sub Initialise(ParamArray Params() As Variant)
' Initalises an instance of the class by:
' Setting DimMax to number of dimensions
' Recording lower and upper bounds in LBounds and UBounds
' Calculating length of each dimension and recording them in DimOffs
' Calculating total number of entries in array and recording in InxMax
' ReDimming MDSarray to the required length
' The format of the call is: Xxxx.Initialise(parameters)
' Xxxx must be an object of type MultDimStrArray which must have been
' defined in one of these two ways:
' (1) Dim Xxxx As New MultDimStrArray
' (2) Dim Xxxx As MultDimStrArray
' Set Xxxx = New MultDimStrArray
' Most people use method 1 although method 2 results in more efficient code
' according to Charles H Pearson. http://www.cpearson.com/excel/classes.aspx
' In all cases, the parameters are a list of bounds. Those bounds can be
' specified as a list in the Initialise call or can be preloaded into an
' array.
' If the bounds are specified within the call, its format will be something like:
' Call Xxxx.Initialise(BoundsForDim1, BoundsForDim2, BoundsForDim3, ...)
' If the bounds are specified in a preloaded array, its format will be something like:
' Bounds = Array(BoundsForDim1, BoundsForDim2, BoundsForDim3, ...)
' Call Xxxx.Initialise(Bounds)
' or
' Bounds(1) = BoundsForDim1
' Bounds(2) = BoundsForDim2
' Bounds(3) = BoundsForDim3
' : : : :
' Call Xxxx.Initialise(Bounds)
' BoundsForDimN can be
' lb " to " ub
' or
' ub
' Each dimension will have its own lower bound (lb) and upper bound (ub).
' If the lb is not specified, it will default to 1. So 'ub' is equivalent to
' '1 To ub'
'Debug.Print "Initalise"
Dim Bounds() As String
Dim BoundParts() As String
Dim InxB As Long
Dim InxP As Long
Dim LB As Long
Dim NumElmnts As Long
' Convert different formats for Params to a single format
LB = LBound(Params)
If LB = UBound(Params) Then
' Single parameter.
'Debug.Assert False
If VarType(Params(LB)) > vbArray Then
' Params(LB) is an array. Call was of the form: .Initialise(Array)
' Copy contents of Array to Bounds
'Debug.Assert False
DimMax = UBound(Params(LB)) - LBound(Params(LB)) + 1
ReDim Bounds(1 To DimMax)
InxB = 1
For InxP = LBound(Params(LB)) To UBound(Params(LB))
' If get error here, element InxP of Array could not be converted to a string
Bounds(InxB) = Params(LB)(InxP)
InxB = InxB + 1
Next
Else
' Params(LB) is not an array. Call was of the form: .Initialise(X)
' where X is "N to M" or "M". Using this class for a 1D array would
' be inefficient but the code would work so it is not forbidden.
'Debug.Assert False
DimMax = 1
ReDim Bounds(1 To 1)
' If get error here, X could not be converted to a string
Bounds(1) = Params(LB)
End If
Else
' Multiple parameters. Call was of the form: .Initialise(X, Y, Z ...)
' where X, Y, Z and so on can be "N to M" or "M".
' Copy X, Y, Z and so to Bounds
'Debug.Assert False
DimMax = UBound(Params) - LBound(Params) + 1
ReDim Bounds(1 To DimMax)
InxB = 1
For InxP = LBound(Params) To UBound(Params)
' If get error here, one of X, Y, Z and so could not be
' converted to a string
Bounds(InxB) = Params(InxP)
InxB = InxB + 1
Next
End If
'Debug.Print "Bounds in call: ";
'For InxB = 1 To UBound(Bounds)
' Debug.Print Bounds(InxB) & " ";
'Next
'Debug.Print
' Decode values in Bounds and store in in LBounds and UBounds
ReDim LBounds(1 To DimMax)
ReDim UBounds(1 To DimMax)
ReDim DimOffs(1 To DimMax)
InxMax = 1
For InxB = 1 To UBound(Bounds)
' Value can be "lb To Ub" or "Ub"
If IsNumeric(Bounds(InxB)) Then
' Upper bound only
'Debug.Assert False
If Int(Bounds(InxB)) = Val(Bounds(InxB)) Then
' Integer value
'Debug.Assert False
LBounds(InxB) = 1
UBounds(InxB) = Bounds(InxB)
Else
Debug.Print "Invalid parameter: " & Bounds(InxB)
Debug.Assert False ' Real ub; only integer indices allowed
DimMax = 0 ' Not initialised
Exit Sub
End If
Else
' lb To ub
BoundParts = Split(LCase(Bounds(InxB)), " to ")
LB = LBound(BoundParts)
If LB + 1 <> UBound(BoundParts) Then
Debug.Print "Invalid parameter: " & Bounds(InxB)
Debug.Assert False ' Not "ub" and not "lb to ub"
DimMax = 0 ' Not initialised
Exit Sub
Else
If IsNumeric(BoundParts(LB)) And _
IsNumeric(BoundParts(LB + 1)) Then
If Int(BoundParts(LB)) = Val(BoundParts(LB)) And _
Int(BoundParts(LB + 1)) = Val(BoundParts(LB + 1)) Then
'Debug.Assert False
LBounds(InxB) = BoundParts(LB)
UBounds(InxB) = BoundParts(LB + 1)
Else
Debug.Print "Invalid parameter: " & Bounds(InxB)
Debug.Assert False ' lb or ub or both are real; indices must be integer
DimMax = 0 ' Not initialised
Exit Sub
End If
Else
Debug.Print "Invalid parameter: " & Bounds(InxB)
Debug.Assert False ' One or both of lb and ub are non-numeric or missing
DimMax = 0 ' Not initialised
Exit Sub
End If
End If
End If
If LBounds(InxB) > UBounds(InxB) Then
Debug.Print "Invalid parameter: " & Bounds(InxB)
Debug.Assert False ' lb must be less than ub
DimMax = 0 ' Not initialised
Exit Sub
End If
Next InxB
' Calculate offset to equivalent element in next repeat for each dimension.
DimOffs(DimMax) = 1
NumElmnts = (UBounds(DimMax) - LBounds(DimMax) + 1)
For InxB = DimMax - 1 To 1 Step -1
DimOffs(InxB) = NumElmnts * DimOffs(InxB + 1)
NumElmnts = (UBounds(InxB) - LBounds(InxB) + 1) ' Need for next loop
Next
InxMax = NumElmnts * DimOffs(1)
ReDim MDSArray(1 To InxMax)
End Sub
Public Sub OutDiag()
Dim ColWidthCrnt As Long
Dim ColWidthTotalLastDim As Long
Dim ColWidthsLast() As Long
Dim ColWidthsNotLast() As Long
Dim Coords() As Long
Dim InxA As Long ' Index into MDSArray
Dim InxC As Long ' Index into Coords
Dim InxD As Long ' Index into dimensions
'Dim InxL As Long ' Index into Last dimension
Dim InxWL As Long ' Index into ColWidthsLast
'Debug.Print "OutDiag"
If DimMax = 0 Then
Debug.Assert False 'Not initialised
Exit Sub
End If
Debug.Print "DimMax=" & DimMax
For InxD = 1 To DimMax
Debug.Print "Dim" & InxD & " Bounds=" & LBounds(InxD) & " to " & _
UBounds(InxD) & " Offset to next repeat=" & DimOffs(InxD)
Next
Debug.Print "InxMax=" & InxMax
Debug.Print
ReDim ColWidthsNotLast(1 To DimMax - 1)
ReDim ColWidthsLast(LBounds(DimMax) To UBounds(DimMax))
' Ensure columns for all but last wide enough for headings and coordinates
For InxD = 1 To DimMax - 1
ColWidthsNotLast(InxD) = Len("D" & CStr(InxD))
'Debug.Print "ColWidthsNotLast(" & InxD & ") initialsed to " & _
' ColWidthsNotLast(InxD) & " because of header ""D" & _
' CStr(InxD) & """"
ColWidthCrnt = Len(CStr(LBounds(InxD)))
If ColWidthsNotLast(InxD) < ColWidthCrnt Then
Debug.Assert False
ColWidthsNotLast(InxD) = ColWidthCrnt
'Debug.Print "ColWidthsNotLast(" & InxD & ") increased to " & _
' ColWidthsNotLast(InxD) & " because of lower bound """ & _
' CStr(LBounds(InxD)) & """"
End If
ColWidthCrnt = Len(CStr(UBounds(InxD)))
If ColWidthsNotLast(InxD) < ColWidthCrnt Then
Debug.Assert False
ColWidthsNotLast(InxD) = ColWidthCrnt
'Debug.Print "ColWidthsNotLast(" & InxD & ") increased to " & _
' ColWidthsNotLast(InxD) & " because of upper bound """ & _
' CStr(UBounds(InxD)) & """"
End If
Next
' Ensure columns for last dimension wide enough for headings
For InxWL = LBounds(DimMax) To UBounds(DimMax)
ColWidthsLast(InxWL) = Len(CStr(InxD))
'Debug.Print "ColWidthsLast(" & InxWL & ") initialised to " & _
' ColWidthsLast(InxWL) & " because of index """ & CStr(InxWL) & """"
Next
' Ensure columns for last dimension wide enough for values
ReDim Coords(1 To DimMax)
' Initialise Coords to indices for first entry in MDS array
For InxC = 1 To DimMax
Coords(InxC) = LBounds(InxC)
Next
'' Output co-ordinates to show which elements caused increase in width
'Debug.Print "(";
'For InxD = 1 To DimMax - 1
' Debug.Print Coords(InxD) & ", ";
'Next
'Debug.Print Coords(DimMax) & ") ";
InxA = 1
' Check length of each value against length of each column for last dimension
' Increase length of column for last dimension if necessary
Do While True
' Length for entry corrsponding specified by Coords
ColWidthCrnt = Len(MDSArray(InxA))
' Column for current index into last dimension
InxWL = Coords(DimMax)
' Increase column width if necessary
If ColWidthsLast(InxWL) < ColWidthCrnt Then
'Debug.Assert False
ColWidthsLast(InxWL) = ColWidthCrnt
'' Report reason for increased column width
'Debug.Print "ColWidthsLast(" & InxWL & ") increased to " & _
' ColWidthsLast(InxWL) & " because of value """ & _
' MDSArray(InxA) & """"
End If
' Step Coords to next entry
For InxD = DimMax To 1 Step -1
If Coords(InxD) < UBounds(InxD) Then
Coords(InxD) = Coords(InxD) + 1
Exit For
Else
Coords(InxD) = LBounds(InxD)
End If
Next
InxA = InxA + 1 ' Step index into MDSArray to match Coords
If InxA > InxMax Then
Exit Do
End If
'' Output co-ordinates to show which elements caused increase in width
'Debug.Print "(";
'For InxD = 1 To DimMax - 1
' Debug.Print Coords(InxD) & ", ";
'Next
'Debug.Print Coords(DimMax) & ") ";
Loop
'Debug.Print
' Output header
Debug.Print "Value for each element in MDSArray"
Debug.Print "|";
For InxD = 1 To DimMax - 1
Debug.Print PadR("D" & CStr(InxD), ColWidthsNotLast(InxD)) & "|";
Next
Debug.Print "|";
For InxWL = LBounds(DimMax) To UBounds(DimMax)
Debug.Print PadR(CStr(InxWL), ColWidthsLast(InxWL)) & "|";
Next
Debug.Print
' Output data rows.
' One row for each value of each index for every dimension except last
' Left of row contains indices for dimensions other thsn last
' Right of row contains values for each index into last dimension
' Initialise Coords to indices for first entry in MDS array
For InxC = 1 To DimMax
Coords(InxC) = LBounds(InxC)
Next
InxA = 1
Do While InxA <= InxMax
Debug.Print "|";
' Output current index for dimensions except last
For InxD = 1 To DimMax - 1
Debug.Print PadR(Coords(InxD), ColWidthsNotLast(InxD)) & "|";
Next
Debug.Print "|";
' Output values for each index into last dimension
Do While True
Debug.Print PadR(MDSArray(InxA), ColWidthsLast(Coords(DimMax))) & "|";
' Step Coords to next entry
For InxD = DimMax To 1 Step -1
If Coords(InxD) < UBounds(InxD) Then
Coords(InxD) = Coords(InxD) + 1
Exit For
Else
Coords(InxD) = LBounds(InxD)
End If
Next
InxA = InxA + 1 ' Step index into MDSArray to match Coords
If InxA > InxMax Then
Exit Do
End If
If Coords(DimMax) = LBounds(DimMax) Then
' Start of new row
Debug.Print
Exit Do
End If
Loop
Loop
Debug.Print
End Sub
Public Sub PutElements(ParamArray Params() As Variant)
' Saves one or more strings starting at a specified element within
' the multi-dimensional string array.
' This sub has two compulsory parameters. The declaration uses a ParamArray
' to allow maximum flexibility in the type of those parameters. Effectively,
' this sub has a declaration of:
' PutElements(ByRef Start() As xxxx, ByRef Values() as yyyy) or
' PutElements(ByRef Start() As xxxx, ByVal Values as yyyy) or
' where xxxx can be any of the integer types plus Variant or String.
' and yyyy can be any type that can be converted to a string plus
' Variant providing all the values within the Variant can be
' converted to strings.
' Start is a one-dimensional array with DimMax, integer elements. If the
' type of the array is Variant or String, the element values must be integer
' or an integer held as a string. The bounds of the array are not important.
' A lower bound of one to match dimension one may be convenient but a lower
' bound of zero or some other value may be used if wished.
' If the MDS array has N dimensions, Start must contain N values each of
' which must be within the bounds for the corresponding dimension. Together,
' the values within Start specify an element with the MDS array.
' Values can be a variable of any type that can be converted to a string.
' Alternately, Values can be a one-dimensional array containing one or more
' elements. If Values contains one element, the value of that element will be
' saved to element Start of the MDS array. If Values contains more than one
' element, the values of those elements will be saved to the MDS array
' starting at Start and continuing in the sequence defined at the top of this
' module until all values in Values have been saved or the last element of
' MDSArray has been reached.
'Debug.Print "PutElements"
If DimMax = 0 Then
Debug.Assert False 'Not initialised
Exit Sub
End If
Dim InxA As Long
Dim InxS As Long
Dim InxV As Long
Dim LB As Long
Dim Start() As Long
Dim UB As Long
LB = LBound(Params)
UB = UBound(Params)
If LB + 1 <> UB Then
Debug.Assert False ' There must be exactly two parameters
Exit Sub
End If
If VarType(Params(LB)) < vbArray Then
Debug.Assert False ' First parameter (Start) must be an array
Exit Sub
End If
' Params(Params(LB)) contains values for Start.
InxS = 1
If UBound(Params(LB)) - LBound(Params(LB)) + 1 <> DimMax Then
Debug.Assert False ' Start must have one entry per dimension
Exit Sub
End If
ReDim Start(1 To DimMax)
For InxV = LBound(Params(LB)) To UBound(Params(LB))
' An error here indicates a value that cannot be converted to a Long
Start(InxS) = Params(LB)(InxV)
If Start(InxS) < LBounds(InxS) Or Start(InxS) > UBounds(InxS) Then
Debug.Assert False ' Index is outside range for dimension
Exit Sub
End If
InxS = InxS + 1
Next
InxA = 1
For InxS = 1 To DimMax
InxA = InxA + (Start(InxS) - LBounds(InxS)) * DimOffs(InxS)
Next
'' Report conversion from coordinates to InxA
'Debug.Print "(";
'For InxS = 1 To DimMax - 1
' Debug.Print Start(InxS) & ", ";
'Next
'Debug.Print Start(DimMax) & ") -> " & InxA
If VarType(Params(UB)) < vbArray Then
' Single value to be stored in element defined by Start
'Debug.Assert False
' An error here indicates Params(UB) cannot be converted to a string
MDSArray(InxA) = Params(UB)
Else
' Array of values to be stored starting at element defined by Start
'Debug.Assert False
'Debug.Print "Params(UB) Bounds: " & LBound(Params(UB)) & " To " & UBound(Params(UB))
For InxV = LBound(Params(UB)) To UBound(Params(UB))
MDSArray(InxA) = Params(UB)(InxV)
'Debug.Print Params(UB)(InxV) & " -> (" & InxA & ")"
InxA = InxA + 1
If InxA > InxMax Then
' Have reached end of MDSArray
Exit For
End If
Next
End If
End Sub
VBA arrays, Variants and Variant arrays
This answer provides the background necessary to understand some of the code within the other answers and to understand why I rejected an alternative approach.
To declare simple variables, I write:
Dim A As Long
Dim B As String
Dim C As Boolean
Dim D As Integer
Dim E As Double
VBA has a selection of intrinsic data types that are not very different from those available with other languages.
VBA has another type:
Dim F As Variant
A Variant might be thought of as untyped or as a container. If I write:
A = 5 ' OK because A is Long
A = "abc" ' Will fail a n alphabetic string cannot be saved in a Long
A = "123" ' OK because string "123" is automatically converted to integer 123
On the other hand, I can write the following without any failures:
F = 5
F = "abc"
F = True
F = 1.23
Each of these values will be held correctly. F can be used in any expression for which its current value is appropriate:
F = 5
F = F + 2
F = "abc"
F = F & "def"
The above statements are all valid but
F = "abc"
F = F + 2
will fail because after setting F to "abc", it cannot be used in an arithmetic expression.
A Variant can also hold an Excel worksheet, a Word document or any Office object. A Variant can also hold an array. When a Variant holds an object or an array, the syntax is as though the Variant has become that object or array. So:
F = Worksheets("Data”)
F.Range("A1") = "abc"
Above, F is now effectively a variable of type Worksheet and any of a Worksheet’s properties or methods can be accessed by F. This was just to give a brief taste on the full scope of Variants; the remainder of this tutorial is limited to arrays.
I can “convert” a Variant to an array in one of two ways:
1) F = VBA.Array(1, "abc", True)
2) ReDim F(0 To 2)
VBA.Array is a function which returns a one-dimensional Variant array with lower bound 0 and enough elements to hold the supplied values. I can also write F = Array(1, "abc", True). Function Array is the same as Function VBA.Array except the lower bound depends on the present and value of the Option Base command.
I only use function Array if I am going to use function LBound to determine the lower bound. I do not fully understand what is and what is not effected by the Option Base command since it is not fully documented. I have seen differences between different versions of different Microsoft products which I am sure are accidental. I am confident a new Microsoft programmer has assumed an old product operates in a sensible manner when it does not. I am very careful to specify both lower and upper bounds if I can. If I cannot specify the lower bound, I check it. I still use routines I wrote under Excel 2003. I believe the lack of problems I encounter with old routines is because I avoid making assumptions about how Excel operates if it is not fully documented.
Returning to the tutorial, ReDim F(0 To 2) effectively converts F to an array with three elements..
All previous discussions have been about one-dimensional arrays. Conventional multi-dimensional arrays are also possible:
Dim G(1 to 5) As Long
Dim H(1 to 5, 1 To 4) As String
Dim I(1 to 5, 1 To 4, 0 To 3) As Boolean
or
Dim G() As Long
Dim H() As String
Dim I() As Boolean
ReDim G(1 to 5)
ReDim H(1 to 5, 1 To 4)
ReDim I(1 to 5, 1 To 4, 0 To 3)
With the first block, the number and size of the dimensions are fixed at compile time. With second block, the number and size of the dimensions are set at runtime and can be changed.
In either case, the syntax for access is:
G(n) = 3
H(n, m) = "abc"
I(n, m, o) = True
This type of multi-dimensional is inappropriate for your requirement. Although the bounds can be changed at runtime, the number of dimensions cannot be changed within a ReDim statement, A Select statement would be need to select from a long list of pre-prepared ReDim statements with one for each possible number of dimensions.
The alternative is ragged or jagged arrays although without them being ragged.
Consider:
Dim F As Variant
ReDim F(0 To 2)
F(0) = VBA.Array(1, 2, 3)
F(1) = VBA.Array(4, 5, 6)
F(2) = VBA.Array(7, 8, 9)
I have made F into a three element array and have then made each element of F into an array. To access the elements of the inner arrays, I write: F(n)(m) where both n and m can be 0, 1 or 2.
I can continue:
F(0)(0) = VBA.Array(10, 11, 12)
After this change, element F(0)(0)(0) has a value of 10 and F(0)(0)(1) has a value of 11.
I can continue this indefinitely. I have read that VBA has a limit of 60 dimensions with conventional multi-dimensional arrays. I have not tried but I cannot see why there would be any limit on the number of dimensions with this technique other than memory.
This technique appears to have the same limitation as regular multi-dimensional arrays. I can write F(0)(0) or F(0)(0)(0) but I cannot change the depth of the simple variable at runtime.
There is also the problem that ReDim F(0)(0 To 2) is rejected by the compiler as invalid syntax. That was why I used VBA.Array to convert F(0) to an array.
The solution is recursion. Consider:
Call ReDimVar(F, "1 To 2", "3 To 4", "0 To 5")
ReDimVar can:
ReDim F(1 To 2)
Call ReDimVar(F(1), "3 To 4", "0 To 5")
Call ReDimVar(F(2), "3 To 4", "0 To 5")
All this can be handled with simple loops. I rejected this technique because recursion is slow and your question implies significant volumes of data and many dimensions. However, to demonstrate that it would work, play with the following:
Sub TryMDVA()
' Demonstrate how to:
' 1) Convert a Variant into a multi-dimension array
' 2) Store values in every element of that multi-dimension array
' 3) Extract values from every element of that multi-dimension array
Dim Coords() As Long
Dim ElementValue As String
Dim InxB As Long ' Index for both Bounds and Coords
Dim InxD1 As Long
Dim InxD2 As Long
Dim InxD3 As Long
Dim LwrBnds As Variant
Dim MDVA As Variant
Dim UppBnds As Variant
LwrBnds = Array(1, 0, -3)
UppBnds = Array(2, 5, 4)
ReDim Bounds(LBound(LwrBnds) To UBound(LwrBnds))
ReDim Coords(LBound(LwrBnds) To UBound(LwrBnds))
Call FormatMDVA(MDVA, LwrBnds, UppBnds)
Debug.Print "Results of formatting MDVA"
Debug.Print "Bounds of MDVA are " & LBound(MDVA) & " to " & UBound(MDVA)
Debug.Print "Bounds of MDVA(1) are " & LBound(MDVA(1)) & " to " & UBound(MDVA(1))
Debug.Print "Bounds of MDVA(2) are " & LBound(MDVA(2)) & " to " & UBound(MDVA(2))
Debug.Print "Bounds or MDVA(1)(0) are " & LBound(MDVA(1)(0)) & " to " & UBound(MDVA(1)(0))
Debug.Print "Bounds or MDVA(2)(5) are " & LBound(MDVA(2)(5)) & " to " & UBound(MDVA(2)(5))
' Initialise Coords to lower bound of each dimension
For InxB = LBound(LwrBnds) To UBound(LwrBnds)
Coords(InxB) = LwrBnds(InxB)
Next
Do While True
' Build element value from coordinates
ElementValue = Coords(LBound(Coords))
For InxB = LBound(LwrBnds) + 1 To UBound(LwrBnds)
ElementValue = ElementValue & "." & Coords(InxB)
Next
' Store element value in element of MDVA specified by Coords
Call PutElement(MDVA, Coords, ElementValue)
' Step Coords. Think of Coords as a speedometer with each wheel marked
' with the available index values for a dimension. Starting on the right,
' check each wheel against the relevant ubound. If it is less than the
' ubound, step it by 1. If it is the upper bound, reset it to the lower
' bound and try the next wheel to the left. If the leftmost wheel is
' to be reset, Coords has been set to all possible values.
For InxB = UBound(LwrBnds) To LBound(LwrBnds) Step -1
If Coords(InxB) < UppBnds(InxB) Then
Coords(InxB) = Coords(InxB) + 1
Exit For
Else
If InxB = LBound(LwrBnds) Then
Exit Do
End If
Coords(InxB) = LwrBnds(InxB)
End If
Next
Loop
Debug.Print "Example values from within MDVA"
Debug.Print "MDVA(1)(0)(-3) = " & MDVA(1)(0)(-3)
Debug.Print "MDVA(1)(0)(-2) = " & MDVA(1)(0)(-2)
Debug.Print "MDVA(2)(3)(0) = " & MDVA(2)(3)(0)
Debug.Print "MDVA(2)(5)(4) = " & MDVA(2)(5)(4)
' Initialise Coords to upper bound of each dimension
For InxB = LBound(UppBnds) To UBound(UppBnds)
Coords(InxB) = UppBnds(InxB)
Next
Debug.Print "List of all values in MDVA"
Do While True
' Output value of element of MDVA identified by Coords
Debug.Print "MDVA(" & Coords(LBound(UppBnds));
For InxB = LBound(UppBnds) + 1 To UBound(UppBnds)
Debug.Print ", " & Coords(InxB);
Next
Debug.Print ") = """ & GetElement(MDVA, Coords) & """"
' Set next value of Coords. Similar to code block in PutElement
' but in the opposite direction
For InxB = UBound(LwrBnds) To LBound(LwrBnds) Step -1
If Coords(InxB) > LwrBnds(InxB) Then
Coords(InxB) = Coords(InxB) - 1
Exit For
Else
If InxB = LBound(LwrBnds) Then
Exit Do
End If
Coords(InxB) = UppBnds(InxB)
End If
Next
Loop
End Sub
Sub FormatMDVA(ByRef MDVA As Variant, LwrBnds As Variant, UppBnds As Variant)
' Size MDVA according to the bounds in the first elements of LwrBnds and
' UppBnds. If there are further elements in LwrBnds and UppBnds, call
' FormatMDVA to format every element of MDVA according to the remaining
' elements.
Dim InxB As Long
Dim InxM As Long
Dim LB As Long
Dim SubLwrBnds As Variant
Dim SubUppBnds As Variant
LB = LBound(LwrBnds)
ReDim MDVA(LwrBnds(LB) To UppBnds(LB))
If LBound(LwrBnds) = UBound(LwrBnds) Then
' All bounds applied
Else
' Another dimension to format
ReDim SubLwrBnds(LB + 1 To UBound(LwrBnds))
ReDim SubUppBnds(LB + 1 To UBound(UppBnds))
' Copy remaining bounds to new arrays
For InxB = LB + 1 To UBound(LwrBnds)
SubLwrBnds(InxB) = LwrBnds(InxB)
SubUppBnds(InxB) = UppBnds(InxB)
Next
For InxM = LwrBnds(LB) To UppBnds(LB)
Call FormatMDVA(MDVA(InxM), SubLwrBnds, SubUppBnds)
Next
End If
End Sub
Function GetElement(ByRef MDVA As Variant, ByRef Coords() As Long) As Variant
' Return the value of the element of MDVA identified by Coords
Dim InxC As Long
Dim LB As Long
Dim SubCoords() As Long
LB = LBound(Coords)
If LB = UBound(Coords) Then
' Have reached innermost array
GetElement = MDVA(Coords(LB))
Else
' At least one more nested array
ReDim SubCoords(LB + 1 To UBound(Coords))
For InxC = LB + 1 To UBound(Coords)
SubCoords(InxC) = Coords(InxC)
Next
GetElement = GetElement(MDVA(Coords(LB)), SubCoords)
End If
End Function
Sub PutElement(ByRef MDVA As Variant, ByRef Coords() As Long, _
ElementValue As Variant)
' Save the value of ElementValue in the element of MDVA identified by Coords
Dim InxC As Long
Dim LB As Long
Dim SubCoords() As Long
LB = LBound(Coords)
If LB = UBound(Coords) Then
' Have reached innermost array
MDVA(Coords(LB)) = ElementValue
Else
' At least one more nested array
ReDim SubCoords(LB + 1 To UBound(Coords))
For InxC = LB + 1 To UBound(Coords)
SubCoords(InxC) = Coords(InxC)
Next
Call PutElement(MDVA(Coords(LB)), SubCoords, ElementValue)
End If
End Sub

How to parse dynamic array arguments to a variable in excel vba

※ This question is a continuation of below problem
How to use nested loop for a Matrix cell in excel vba
I would like to pass dynamic Array(arguments), and i was trying below, but it is not working correctly. Could you please help me.
Dim StartrowArr, Startrow1Arr, J As Integer
Dim flRow, dtRow As String
Set filRng = Worksheets("Sheet1").Range("C1:C50")
Set dtlRng = Worksheets("Sheet1").Range("F1:F50")
For Each cell In filRng
If cell.Value <> "" Then
ftRow = ftRow & cell.Row & ","
End If
Next cell
ftRow = Left(ftRow, Len(ftRow) - 1)
Debug.Print ftRowNo
For Each cell In dtlRng
If cell.Value <> "" Then
dtRow = dtRow & cell.Row & ","
End If
Next cell
dtRow = Left(dtRow, Len(dtRow) - 1)
Debug.Print dtRow
StartrowArr = Array(filRowNo) ※ dynamic array args
Startrow1Arr = Array(dtlRowNo)
but after initializing Array(args) like above, it returns error 1004 on [Startrow1, init with 0]. I also tried CInt(ftRow) to typecast to Integer from String. nothings changed. Moreover, log shows that Startrow, Startrow1 got values like below.
Startrow: 2, 4, 7
Startrow1: 2611 ※ should be 2, 6, 11
However, If I initialize the StartrowArr = Array(2,4,7), statically. it works perfect.
How can I pass the arguments correctly to StartrowArr and Startrow1Arr.
To making Dynamic array, use redim preserve .
Sub test()
Dim StartrowArr(), Startrow1Arr(), J As Integer
Dim flRow, dtRow As String
Dim Cell As Range
Dim k As Long, n As Long
Set filRng = Worksheets("Sheet1").Range("C1:C50")
Set dtlRng = Worksheets("Sheet1").Range("F1:F50")
For Each Cell In filRng
If Cell.Value <> "" Then
'ftRow = ftRow & cell.Row & ","
ReDim Preserve StartrowArr(k)
StartrowArr(k) = Cell.Row
k = k + 1
End If
Next Cell
'ftRow = Left(ftRow, Len(ftRow) - 1)
Debug.Print Join(StartrowArr, ",")
For Each Cell In dtlRng
If Cell.Value <> "" Then
'dtRow = dtRow & Cell.Row & ","
ReDim Preserve Startrow1Arr(n)
Startrow1Arr(n) = Cell.Row
n = n + 1
End If
Next Cell
'dtRow = Left(dtRow, Len(dtRow) - 1)
Debug.Print Join(Startrow1Arr, ",")
'StartrowArr = Array(mapRowNo) '※ dynamic array args
'Startrow1Arr = Array(tcRowNo)
End Sub

Converting an Excel list according to row indexes

I'm trying to convert a list in Excel VBA as follows:
My original list in the one colored in grey. It shows a sequence.
I want to generate the list on the right according to each number location.
For example:
3 is second in the left list so 2 is on the third location in the right list;
6 is fourth in the left list so 4 is on the sixth location in the right list ...
I tried using 'For' loops in VBA, but it's getting a bit long and complex, is there a way to do it by using arrays in VBA?
A formula can easily achieve this. Assuming data is in A1:A8, in B1 and copied down:
=MATCH(ROW(),A$1:A$8,0)
This will work, just set the first, last and ranges as needed.
Private Sub cbSort_Click()
Dim wArray As Variant, dArray As Variant
Dim first As Integer, last As Integer
Dim i As Integer, j As Integer
first = 1
last = 8
Set wArray = Range("A" & first & ":A" & last)
ReDim dArray(1 To last - first + 1, 1 To 1)
j = 1
For i = first To last
dArray(wArray(i, 1), 1) = j
j = j + 1
Next i
Range("B" & first & ":B" & last) = dArray
End Sub
Option Explicit
Sub Main()
Dim source As Range
On Error GoTo ErrTransformIt
Set source = Application.InputBox(prompt:="Source", Type:=8)
TransformIt source
Exit Sub
ErrTransformIt:
MsgBox Err.Description
End Sub
Private Sub TransformIt(ByVal source As Range)
Dim target As Range
Dim c As Range
Dim i As Integer
Dim firstRow As Long
firstRow = source(1).Row
i = 1
For Each c In source.Cells
Set target = ActiveSheet.Cells(firstRow + c.Value - 1, c.Column + 1)
If target.Value <> "" Then
MsgBox "Target is already used by [" & target.Value & "]", vbExclamation
Exit Sub
End If
target.Value = i
i = i + 1
Next c
End Sub

VBA using ubound on a multidimensional array

Ubound can return the max index value of an array, but in a multidimensional array, how would I specify WHICH dimension I want the max index of?
For example
Dim arr(1 to 4, 1 to 3) As Variant
In this 4x3 array, how would I have Ubound return 4, and how would I have Ubound return 3?
ubound(arr, 1)
and
ubound(arr, 2)
You need to deal with the optional Rank parameter of UBound.
Dim arr(1 To 4, 1 To 3) As Variant
Debug.Print UBound(arr, 1) '◄ returns 4
Debug.Print UBound(arr, 2) '◄ returns 3
More at: UBound Function (Visual Basic)
[This is a late answer addressing the title of the question (since that is what people would encounter when searching) rather than the specifics of OP's question which has already been answered adequately]
Ubound is a bit fragile in that it provides no way to know how many dimensions an array has. You can use error trapping to determine the full layout of an array. The following returns a collection of arrays, one for each dimension. The count property can be used to determine the number of dimensions and their lower and upper bounds can be extracted as needed:
Function Bounds(A As Variant) As Collection
Dim C As New Collection
Dim v As Variant, i As Long
On Error GoTo exit_function
i = 1
Do While True
v = Array(LBound(A, i), UBound(A, i))
C.Add v
i = i + 1
Loop
exit_function:
Set Bounds = C
End Function
Used like this:
Sub test()
Dim i As Long
Dim A(1 To 10, 1 To 5, 4 To 10) As Integer
Dim B(1 To 5) As Variant
Dim C As Variant
Dim sizes As Collection
Set sizes = Bounds(A)
Debug.Print "A has " & sizes.Count & " dimensions:"
For i = 1 To sizes.Count
Debug.Print sizes(i)(0) & " to " & sizes(i)(1)
Next i
Set sizes = Bounds(B)
Debug.Print vbCrLf & "B has " & sizes.Count & " dimensions:"
For i = 1 To sizes.Count
Debug.Print sizes(i)(0) & " to " & sizes(i)(1)
Next i
Set sizes = Bounds(C)
Debug.Print vbCrLf & "C has " & sizes.Count & " dimensions:"
For i = 1 To sizes.Count
Debug.Print sizes(i)(0) & " to " & sizes(i)(1)
Next i
End Sub
Output:
A has 3 dimensions:
1 to 10
1 to 5
4 to 10
B has 1 dimensions:
1 to 5
C has 0 dimensions:
UBound(myArray, 1) returns the number of rows in 2d array
UBound(myArray, 2) returns the number of columns in 2d array
However, let's go 1 step further and assume that you need the last row and last column of range, that has been written as a 2d array. That row (or column) should be converted to a 1d array. E.g. if our 2d array looks like this:
Then running the code below, will give you 2 1D arrays, that are the last column and last row:
Sub PrintMultidimensionalArrayExample()
Dim myRange As Range: Set myRange = Range("a1").CurrentRegion
Dim myArray As Variant: myArray = myRange
Dim lastRowArray As Variant: lastRowArray = GetRowFromMdArray(myArray, UBound(myArray, 1))
Dim lastColumnArray As Variant
lastColumnArray = GetColumnFromMdArray(myArray, UBound(myArray, 2))
End Sub
Function GetColumnFromMdArray(myArray As Variant, myCol As Long) As Variant
'returning a column from multidimensional array
'the returned array is 0-based, but the 0th element is Empty.
Dim i As Long
Dim result As Variant
Dim size As Long: size = UBound(myArray, 1)
ReDim result(size)
For i = LBound(myArray, 1) To UBound(myArray, 1)
result(i) = myArray(i, myCol)
Next
GetColumnFromMdArray = result
End Function
Function GetRowFromMdArray(myArray As Variant, myRow As Long) As Variant
'returning a row from multidimensional array
'the returned array is 0-based, but the 0th element is Empty.
Dim i As Long
Dim result As Variant
Dim size As Long: size = UBound(myArray, 2)
ReDim result(size)
For i = LBound(myArray, 2) To UBound(myArray, 2)
result(i) = myArray(myRow, i)
Next
GetRowFromMdArray = result
End Function
In addition to the already excellent answers, also consider this function to retrieve both the number of dimensions and their bounds, which is similar to John's answer, but works and looks a little differently:
Function sizeOfArray(arr As Variant) As String
Dim str As String
Dim numDim As Integer
numDim = NumberOfArrayDimensions(arr)
str = "Array"
For i = 1 To numDim
str = str & "(" & LBound(arr, i) & " To " & UBound(arr, i)
If Not i = numDim Then
str = str & ", "
Else
str = str & ")"
End If
Next i
sizeOfArray = str
End Function
Private Function NumberOfArrayDimensions(arr As Variant) As Integer
' By Chip Pearson
' http://www.cpearson.com/excel/vbaarrays.htm
Dim Ndx As Integer
Dim Res As Integer
On Error Resume Next
' Loop, increasing the dimension index Ndx, until an error occurs.
' An error will occur when Ndx exceeds the number of dimension
' in the array. Return Ndx - 1.
Do
Ndx = Ndx + 1
Res = UBound(arr, Ndx)
Loop Until Err.Number <> 0
NumberOfArrayDimensions = Ndx - 1
End Function
Example usage:
Sub arrSizeTester()
Dim arr(1 To 2, 3 To 22, 2 To 9, 12 To 18) As Variant
Debug.Print sizeOfArray(arr())
End Sub
And its output:
Array(1 To 2, 3 To 22, 2 To 9, 12 To 18)
Looping D3 ways;
Sub SearchArray()
Dim arr(3, 2) As Variant
arr(0, 0) = "A"
arr(0, 1) = "1"
arr(0, 2) = "w"
arr(1, 0) = "B"
arr(1, 1) = "2"
arr(1, 2) = "x"
arr(2, 0) = "C"
arr(2, 1) = "3"
arr(2, 2) = "y"
arr(3, 0) = "D"
arr(3, 1) = "4"
arr(3, 2) = "z"
Debug.Print "Loop Dimension 1"
For i = 0 To UBound(arr, 1)
Debug.Print "arr(" & i & ", 0) is " & arr(i, 0)
Next i
Debug.Print ""
Debug.Print "Loop Dimension 2"
For j = 0 To UBound(arr, 2)
Debug.Print "arr(0, " & j & ") is " & arr(0, j)
Next j
Debug.Print ""
Debug.Print "Loop Dimension 1 and 2"
For i = 0 To UBound(arr, 1)
For j = 0 To UBound(arr, 2)
Debug.Print "arr(" & i & ", " & j & ") is " & arr(i, j)
Next j
Next i
Debug.Print ""
End Sub

Print Dynamic Error Array to Sheet

I'm having troubles getting my Error array to print to a range. I'm fairly sure I'm resizing it incorrectly, but I'm not sure how to fix it. I created a test add which just added garbage data from columns A and B, but normally AddPartError would be call from within various Subs/Functions, and then at the end of the main script process the array should be dumped onto a sheet. Here are the relevant functions:
Sub testadd()
For Each i In ActiveSheet.Range("A1:A10")
Call AddPartError(i.value, i.Offset(0, 1))
Next i
tmp = PartErrors
PrintArray PartErrors, ActiveWorkbook.Worksheets("Sheet1").[D1]
Erase PartErrors
tmp1 = PartErrors
PartErrorsDefined = 0
End Sub
Sub PrintArray(Data As Variant, Cl As Range)
Cl.Resize(UBound(Data, 1), 2) = Data
End Sub
Private Sub AddPartError(part As String, errType As String)
If Not PartErrorsDefined = 1 Then
ReDim PartErrors(1 To 1) As Variant
PartErrorsDefined = 1
End If
PartErrors(UBound(PartErrors)) = Array(part, errType)
ReDim Preserve PartErrors(1 To UBound(PartErrors) + 1) As Variant
End Sub
Ok. I did a bit of checking and the reason this doesn't work is because of your array structure of PartErrors
PartErrors is a 1 dimensional array and you are adding arrays to it, so instead of multi dimentional array you end up with a jagged array, (or array of arrays) when you actually want a 2d array
So to fix this, I think you need to look at changing your array to 2d. Something like the below
Private Sub AddPartError(part As String, errType As String)
If Not PartErrorsDefined = 1 Then
ReDim PartErrors(1 To 2, 1 To 1) As Variant
PartErrorsDefined = 1
End If
PartErrors(1, UBound(PartErrors, 2)) = part 'Array(part, errType)
PartErrors(2, UBound(PartErrors, 2)) = errType
ReDim Preserve PartErrors(1 To 2, 1 To UBound(PartErrors, 2) + 1) As Variant
End Sub
and
Sub PrintArray(Data As Variant, Cl As Range)
Cl.Resize(UBound(Data, 2), 2) = Application.Transpose(Data)
End Sub
NB. You also need to Transpose your array to fit in the range you specified.
You code is a little hard to follow, but redim clears the data that is in the array, so I think you need to use the "Preserve" keyword.
Below is some example code you can work through to give you the idea of how it works, but you will need to spend some time working out how to fit this into your code.
Good luck!
Sub asda()
'declare an array
Dim MyArray() As String
'First time we size the array I do not need the "Preserve keyword
'there is not data in the array to start with!!!
'Here we size it too 2 by 5
ReDim MyArray(1, 4)
'Fill Array with Stuff
For i = 0 To 4
MyArray(0, i) = "Item at 0," & i
MyArray(1, i) = "Item at 1," & i
Next
' "Print" data to worksheet
Dim Destination1 As Range
Set Destination1 = Range("a1")
Destination1.Resize(UBound(MyArray, 1) + 1, UBound(MyArray, 2) + 1).Value = MyArray
'Now lets resize that arrray
'YOU CAN ONLY RESIZE THE LAST SIZE OF THE ARRAY - in this case 4 to 6...
ReDim Preserve MyArray(1, 6)
For i = 5 To 6
MyArray(0, i) = "New Item at 0," & i
MyArray(1, i) = "New Item at 1," & i
Next
'and let put that next to our first list
' "Print" data to worksheet
Dim Destination2 As Range
Set Destination2 = Range("A4")
Destination2.Resize(UBound(MyArray, 1) + 1, UBound(MyArray, 2) + 1).Value = MyArray
End Sub

Resources