Menu
How should I implement this function?
Public Function ArraySlice(arr As Variant, dimension as Long, index as Long) As Variant
'Implementation here
End Function
Suppose I wanted a slice of an array. I specify an array, a dimension and an index on that dimension for which I want the slice.
As a concrete example, suppose I have the following 5x4 2D array
0 1 2 3 4
______________
0| 1 1 2 3 1
1| 3 4 2 1 5
2| 4 5 3 2 6
3| 3 5 2 1 3
If the horizontal dimension is 1 and the vertical is 2, the return value of ArraySlice(array, 1, 3) would be a 1x4 2D array. The chosen dimension 2 was flattened and the only remaining values are the ones that were originally at index 3 on dimension 2:
0
____
0| 3
1| 1
2| 2
3| 1
How would you implement this in VBA? The only implementations I can think of would involve CopyMemory unless I limited the number of dimensions allowable and hard coded every case.
NOTE: Here is how I would get the dimensions of the array
UPDATE
Here are a couple more examples of the operation
For the 2D array
0 1 2 3 4
______________
0| 1 1 2 3 1
1| 3 4 2 1 5
2| 4 5 3 2 6
3| 3 5 2 1 3
The result of ArraySlice(array, 2, 2) would be
0 1 2 3 4
______________
0| 4 5 3 2 6
Suppose I had a 3x3x3 array comprised of the following 2 dimensional slices this example has been changed to make it clearer
0 1 2 0 1 2 0 1 2
0 _________ 1 _________ 2 _________
0| 1 1 1 0| 4 4 4 0| 7 7 7
1| 2 2 2 1| 5 5 5 1| 8 8 8
2| 3 3 3 2| 6 6 6 2| 9 9 9
(constructed like so)
Dim arr() As Long
ReDim arr(2, 2, 2)
arr(0, 0, 0) = 1
arr(1, 0, 0) = 1
arr(2, 0, 0) = 1
arr(0, 1, 0) = 2
arr(1, 1, 0) = 2
arr(2, 1, 0) = 2
arr(0, 2, 0) = 3
arr(1, 2, 0) = 3
arr(2, 2, 0) = 3
arr(0, 0, 1) = 4
arr(1, 0, 1) = 4
arr(2, 0, 1) = 4
arr(0, 1, 1) = 5
arr(1, 1, 1) = 5
arr(2, 1, 1) = 5
arr(0, 2, 1) = 6
arr(1, 2, 1) = 6
arr(2, 2, 1) = 6
arr(0, 0, 2) = 7
arr(1, 0, 2) = 7
arr(2, 0, 2) = 7
arr(0, 1, 2) = 8
arr(1, 1, 2) = 8
arr(2, 1, 2) = 8
arr(0, 2, 2) = 9
arr(1, 2, 2) = 9
arr(2, 2, 2) = 9
(the dimensions are used in the mathematical x, y, z sense as opposed to the rows/cols sense)
The result of ArraySlice(array, 3, 1) would be the 3x3x1 array
0 1 2
0 _________
0| 4 4 4
1| 5 5 5
2| 6 6 6
The result of ArraySlice(array, 2, 2) would be the 3x1x3 array
0 1 2 0 1 2 0 1 2
0 _________ 1 _________ 2 _________
0| 3 3 3 0| 6 6 6 0| 9 9 9
UPDATE2
For DavidZemens, here is an example that would allow easier tracking of the elements involved:
For a 3x3x3 array constructed like so
Dim arr() As Long
ReDim arr(2, 2, 2)
arr(0, 0, 0) = "000"
arr(1, 0, 0) = "100"
arr(2, 0, 0) = "200"
arr(0, 1, 0) = "010"
arr(1, 1, 0) = "110"
arr(2, 1, 0) = "210"
arr(0, 2, 0) = "020"
arr(1, 2, 0) = "120"
arr(2, 2, 0) = "220"
arr(0, 0, 1) = "001"
arr(1, 0, 1) = "101"
arr(2, 0, 1) = "201"
arr(0, 1, 1) = "011"
arr(1, 1, 1) = "111"
arr(2, 1, 1) = "211"
arr(0, 2, 1) = "021"
arr(1, 2, 1) = "121"
arr(2, 2, 1) = "221"
arr(0, 0, 2) = "001"
arr(1, 0, 2) = "102"
arr(2, 0, 2) = "202"
arr(0, 1, 2) = "012"
arr(1, 1, 2) = "112"
arr(2, 1, 2) = "212"
arr(0, 2, 2) = "022"
arr(1, 2, 2) = "122"
arr(2, 2, 2) = "222"
The result of ArraySlice(array, 3, 1) would be the 3x3x1 array
0 1 2
0 ___________________
0| "001" "101" "201"
1| "011" "111" "211"
2| "021" "121" "221"
FINAL UPDATE
Here is the complete solution - you can assume that the Array functions are implemented as @GSerg suggests in the accepted answer. I decided that it makes more sense to completely flatten the sliced dimension, so if a slice of a 3x3x3 array ("cube") is 3x1x3, it gets flattened to 3x3. I still have to resolve the case where flattening a 1 dimensional array would yield a 0 dimensional array by this method.
Public Function ArraySlice(arr As Variant, dimension As Long, index As Long) As Variant
'TODO: Assert that arr is an Array
'TODO: Assert dimension is valid
'TODO: Assert index is valid
Dim arrDims As Integer
arrDims = GetArrayDim(arr) 'N dimensions
Dim arrType As Integer
arrType = GetArrayType(arr)
Dim zeroIndexedDimension As Integer
zeroIndexedDimension = dimension - 1 'Make the dimension zero indexed by subtracting one, for easier math
Dim newArrDims As Integer
newArrDims = arrDims - 1 'N-1 dimensions since we're flattening "dimension" on "index"
Dim arrDimSizes() As Variant
Dim newArrDimSizes() As Variant
ReDim arrDimSizes(0 To arrDims - 1)
ReDim newArrDimSizes(0 To newArrDims - 1)
Dim i As Long
For i = 0 To arrDims - 1
arrDimSizes(i) = UBound(arr, i + 1) - LBound(arr, i + 1) + 1
Next
'Get the size of each corresponding dimension of the original
For i = 0 To zeroIndexedDimension - 1
newArrDimSizes(i) = arrDimSizes(i)
Next
'Skip over "dimension" since we're flattening it
'Get the remaining dimensions, off by one
For i = zeroIndexedDimension To arrDims - 2
newArrDimSizes(i) = arrDimSizes(i + 1)
Next
Dim newArray As Variant
newArray = CreateArray(arrType, newArrDims, newArrDimSizes)
'Iterate through dimensions, copying
Dim arrCurIndices() As Variant
Dim newArrCurIndices() As Variant
ReDim arrCurIndices(0 To arrDims - 1)
ReDim newArrCurIndices(0 To newArrDims - 1)
arrCurIndices(zeroIndexedDimension) = index 'This is the slice
Do While 1
'Copy the element
PutArrayElement newArray, GetArrayElement(arr, arrCurIndices), newArrCurIndices
'Iterate both arrays to the next position
If Not IncrementIndices(arrCurIndices, arrDimSizes, zeroIndexedDimension) Then
'If we've copied all the elements
Exit Do
End If
IncrementIndices newArrCurIndices, newArrDimSizes
Loop
ArraySlice = newArray
End Function
Private Function IncrementIndices(arrIndices As Variant, arrDimensionSizes As Variant, Optional zeroIndexedDimension As Integer = -2) As Boolean
'IncrementArray iterates sequentially through all valid indices, given the sizes in arrDimensionSizes
'For example, suppose the function is called repeatedly with starting arrIndices of [0, 0, 0] and arrDimensionSizes of [3, 1, 3].
'The result would be arrIndices changing as follows:
'[0, 0, 0] first call
'[0, 0, 1]
'[0, 0, 2]
'[1, 0, 0]
'[1, 0, 1]
'[1, 0, 2]
'[2, 0, 0]
'[2, 0, 1]
'[2, 0, 2]
'The optional "dimension" parameter allows a dimension to be frozen and not included in the iteration.
'For example, suppose the function is called repeatedly with starting arrIndices of [0, 1, 0] and arrDimensionSizes of [3, 3, 3] and dimension = 2
'[0, 1, 0] first call
'[0, 1, 1]
'[0, 1, 2]
'[1, 1, 0]
'[1, 1, 1]
'[1, 1, 2]
'[2, 1, 0]
'[2, 1, 1]
'[2, 1, 2]
Dim arrCurDimension As Integer
arrCurDimension = UBound(arrIndices)
'If this dimension is "full" or if it is the frozen dimension, skip over it looking for a carry
While arrIndices(arrCurDimension) = arrDimensionSizes(arrCurDimension) - 1 Or arrCurDimension = zeroIndexedDimension
'Carry
arrCurDimension = arrCurDimension - 1
If arrCurDimension = -1 Then
IncrementIndices = False
Exit Function
End If
Wend
arrIndices(arrCurDimension) = arrIndices(arrCurDimension) + 1
While arrCurDimension < UBound(arrDimensionSizes)
arrCurDimension = arrCurDimension + 1
If arrCurDimension <> zeroIndexedDimension Then
arrIndices(arrCurDimension) = 0
End If
Wend
IncrementIndices = True
End Function
439
Now that I wrote all this and realized that you will need a similar element setter (based on SafeArrayPutElement instead of SafeArrayGetElement) and a generic array creation routine, I'm thinking whether it is actually a bad thing to hardcode all 60 cases.
The reason is that there can be at most 60 dimensions in a VBA array, and 60 cases are not difficult to hardcode
I did not even type this code in, I used some Excel formulas to generate it:
Public Function GetArrayElement(ByRef arr As Variant, ParamArray indices()) As Variant
Dim count As Long, lb As Long
lb = LBound(indices)
count = UBound(indices) - lb + 1
Select Case count
Case 1: GetArrayElement = arr(indices(lb))
Case 2: GetArrayElement = arr(indices(lb), indices(lb + 1))
....
Case Else
Err.Raise 5, , "There can be no more than 60 dimensions"
End Select
End Function
Public Sub SetArrayElement(ByRef arr As Variant, ByRef value As Variant, ParamArray indices())
Dim count As Long, lb As Long
lb = LBound(indices)
count = UBound(indices) - lb + 1
Select Case count
Case 1: arr(indices(lb)) = value
Case 2: arr(indices(lb), indices(lb + 1)) = value
....
Case Else
Err.Raise 5, , "There can be no more than 60 dimensions"
End Select
End Sub
Unfortunately it's about twice longer than it is allowed in a post, so there is a link to full version: http://pastebin.com/KVqV3vyU
53
My complete code is below, arr input is 1, 2 or 3 dimension array, 1 dimension array will return false.
Public Function ArraySlice(arr As Variant, dimension As Long, index As Long) As Variant
Dim arrDimension() As Byte
Dim retArray()
Dim i As Integer, j As Integer
Dim arrSize As Long
' Get array dimension and size
On Error Resume Next
For i = 1 To 3
arrSize = 0
arrSize = CInt(UBound(arr, i))
If arrSize <> 0 Then
ReDim Preserve arrDimension(i)
arrDimension(i) = UBound(arr, i)
End If
Next i
On Error GoTo 0
Select Case UBound(arrDimension)
Case 2
If dimension = 1 Then
ReDim retArray(arrDimension(2))
For i = 0 To arrDimension(2)
retArray(i) = arr(index, i)
Next i
ElseIf dimension = 2 Then
ReDim retArray(arrDimension(1))
For i = 0 To arrDimension(1)
retArray(i) = arr(i, index)
Next i
End If
Case 3
If dimension = 1 Then
ReDim retArray(0, arrDimension(2), arrDimension(3))
For j = 0 To arrDimension(3)
For i = 0 To arrDimension(2)
retArray(0, i, j) = arr(index, i, j)
Next i
Next j
ElseIf dimension = 2 Then
ReDim retArray(arrDimension(1), 0, arrDimension(3))
For j = 0 To arrDimension(3)
For i = 0 To arrDimension(1)
retArray(i, 0, j) = arr(i, index, j)
Next i
Next j
ElseIf dimension = 3 Then
ReDim retArray(arrDimension(1), arrDimension(2), 0)
For j = 0 To arrDimension(2)
For i = 0 To arrDimension(1)
retArray(i, j, 0) = arr(i, j, index)
Next i
Next j
End If
Case Else
ArraySlice = False
Exit Function
End Select
ArraySlice = retArray
End Function
Simply test by the code below
Sub test()
Dim arr2D()
Dim arr3D()
Dim ret
ReDim arr2D(4, 3)
arr2D(0, 0) = 1
arr2D(1, 0) = 1
arr2D(2, 0) = 2
arr2D(3, 0) = 3
arr2D(4, 0) = 1
arr2D(0, 1) = 3
arr2D(1, 1) = 4
arr2D(2, 1) = 2
arr2D(3, 1) = 1
arr2D(4, 1) = 5
arr2D(0, 2) = 4
arr2D(1, 2) = 5
arr2D(2, 2) = 3
arr2D(3, 2) = 2
arr2D(4, 2) = 6
arr2D(0, 3) = 3
arr2D(1, 3) = 5
arr2D(2, 3) = 2
arr2D(3, 3) = 1
arr2D(4, 3) = 3
ReDim arr3D(2, 2, 2)
arr3D(0, 0, 0) = 1
arr3D(1, 0, 0) = 1
arr3D(2, 0, 0) = 1
arr3D(0, 1, 0) = 2
arr3D(1, 1, 0) = 2
arr3D(2, 1, 0) = 2
arr3D(0, 2, 0) = 3
arr3D(1, 2, 0) = 3
arr3D(2, 2, 0) = 3
arr3D(0, 0, 1) = 4
arr3D(1, 0, 1) = 4
arr3D(2, 0, 1) = 4
arr3D(0, 1, 1) = 5
arr3D(1, 1, 1) = 5
arr3D(2, 1, 1) = 5
arr3D(0, 2, 1) = 6
arr3D(1, 2, 1) = 6
arr3D(2, 2, 1) = 6
arr3D(0, 0, 2) = 7
arr3D(1, 0, 2) = 7
arr3D(2, 0, 2) = 7
arr3D(0, 1, 2) = 8
arr3D(1, 1, 2) = 8
arr3D(2, 1, 2) = 8
arr3D(0, 2, 2) = 9
arr3D(1, 2, 2) = 9
arr3D(2, 2, 2) = 9
ReDim arr3D(2, 2, 2)
arr3D(0, 0, 0) = "000"
arr3D(1, 0, 0) = "100"
arr3D(2, 0, 0) = "200"
arr3D(0, 1, 0) = "010"
arr3D(1, 1, 0) = "110"
arr3D(2, 1, 0) = "210"
arr3D(0, 2, 0) = "020"
arr3D(1, 2, 0) = "120"
arr3D(2, 2, 0) = "220"
arr3D(0, 0, 1) = "001"
arr3D(1, 0, 1) = "101"
arr3D(2, 0, 1) = "201"
arr3D(0, 1, 1) = "011"
arr3D(1, 1, 1) = "111"
arr3D(2, 1, 1) = "211"
arr3D(0, 2, 1) = "021"
arr3D(1, 2, 1) = "121"
arr3D(2, 2, 1) = "221"
arr3D(0, 0, 2) = "001"
arr3D(1, 0, 2) = "102"
arr3D(2, 0, 2) = "202"
arr3D(0, 1, 2) = "012"
arr3D(1, 1, 2) = "112"
arr3D(2, 1, 2) = "212"
arr3D(0, 2, 2) = "022"
arr3D(1, 2, 2) = "122"
arr3D(2, 2, 2) = "222"
' Here is function call
ret = ArraySlice(arr3D, 3, 1)
End If
If you love us? You can donate to us via Paypal or buy me a coffee so we can maintain and grow! Thank you!
Donate Us With