Shafts of the VBA array (not in the sense of Python)

Question

How to implement this function?

Public Function ArraySlice(arr As Variant, dimension as Long, index as Long) As Variant 'Implementation here End Function 

Suppose I need a fragment of an array. I specify the array, dimension and index for this dimension for which I want a slice.

As a specific 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 size is 1 and the vertical is 2, the return value of ArraySlice(array, 1, 3) will be a 1x4 2D array. Selected dimension 2 was flattened, and the only remaining values ​​were those that were originally at index 3 in size 2:

  0 ____ 0| 3 1| 1 2| 2 3| 1 

How do you implement this in VBA? The only implementations I can think of will include CopyMemory, unless I limit the number of valid and hardcoded sizes in each case.

NOTE: Here is how I can get the dimensions of the array.

UPDATE

Here are some more examples of the operation.

For a 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) will be

  0 1 2 3 4 ______________ 0| 4 5 3 2 6 

Suppose I had a 3x3x3 matrix consisting of the following 2 dimensional slices, this example was modified 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 

(built like that)

 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 

(dimensions are used in the mathematical sense of x, y, z, as opposed to the meaning of rows / columns)

The result of ArraySlice(array, 3, 1) will be a 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) will be a 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 will make it easier to track the elements involved:

For a 3x3x3 array constructed this way

 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) will be a 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 sense to completely smooth the sliced ​​size, so if the slice of the 3x3x3 array (“cube”) is 3x1x3, it is smoothed to 3x3. I still have to solve the case when using this method, smoothing a 1-dimensional array will give a 0-dimensional array.

 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 

Answer 1

I'm not sure I fully understand the logic and relationship between function arguments and the result, but there is already a function to access the universal element, SafeArrayGetElement . It allows you to access an array element with unknown sizes at compile time, all you need is an array pointer (for reference only, the code in this answer has been improved).

In a separate module:

 Option Explicit Private Declare Function GetMem2 Lib "msvbvm60" (ByVal pSrc As Long, ByVal pDst As Long) As Long ' Replace with CopyMemory if feel bad about it Private Declare Function GetMem4 Lib "msvbvm60" (ByVal pSrc As Long, ByVal pDst As Long) As Long ' Replace with CopyMemory if feel bad about it Private Declare Function PutMem2 Lib "msvbvm60" (ByVal pDst As Long, ByVal NewValue As Integer) As Long ' Replace with CopyMemory if feel bad about it Private Declare Function PutMem4 Lib "msvbvm60" (ByVal pDst As Long, ByVal NewValue As Long) As Long ' Replace with CopyMemory if feel bad about it Private Declare Function SafeArrayGetElement Lib "oleaut32.dll" (ByVal psa As Long, ByRef rgIndices As Long, ByRef pv As Any) As Long Private Declare Function SafeArrayGetVartype Lib "oleaut32.dll" (ByVal psa As Long, ByRef pvt As Integer) As Long Private Const VT_BYREF As Long = &H4000& Private Const S_OK As Long = &H0& Private Function pArrPtr(ByRef arr As Variant) As Long 'Warning: returns *SAFEARRAY, not **SAFEARRAY 'VarType lies to you, hiding important differences. Manual VarType here. Dim vt As Integer GetMem2 ByVal VarPtr(arr), ByVal VarPtr(vt) If (vt And vbArray) <> vbArray Then Err.Raise 5, , "Variant must contain an array" End If 'see https://msdn.microsoft.com/en-us/library/windows/desktop/ms221627%28v=vs.85%29.aspx If (vt And VT_BYREF) = VT_BYREF Then 'By-ref variant array. Contains **pparray at offset 8 GetMem4 ByVal VarPtr(arr) + 8, ByVal VarPtr(pArrPtr) 'pArrPtr = arr->pparray; GetMem4 ByVal pArrPtr, ByVal VarPtr(pArrPtr) 'pArrPtr = *pArrPtr; Else 'Non-by-ref variant array. Contains *parray at offset 8 GetMem4 ByVal VarPtr(arr) + 8, ByVal VarPtr(pArrPtr) 'pArrPtr = arr->parray; End If End Function Public Function GetArrayElement(ByRef arr As Variant, ParamArray indices() As Variant) As Variant Dim pSafeArray As Long pSafeArray = pArrPtr(arr) Dim long_indices() As Long ReDim long_indices(0 To UBound(indices) - LBound(indices)) Dim i As Long For i = LBound(long_indices) To UBound(long_indices) long_indices(i) = indices(LBound(indices) + i) Next 'Type safety checks - remove/cache if you know what you're doing. Dim hresult As Long Dim vt As Integer hresult = SafeArrayGetVartype(pSafeArray, vt) If hresult <> S_OK Then Err.Raise hresult, , "Cannot get array var type." Select Case vt Case vbVariant hresult = SafeArrayGetElement(ByVal pSafeArray, long_indices(LBound(long_indices)), GetArrayElement) Case vbBoolean, vbCurrency, vbDate, vbDecimal, vbByte, vbInteger, vbLong, vbNull, vbEmpty, vbSingle, vbDouble, vbString, vbObject hresult = SafeArrayGetElement(ByVal pSafeArray, long_indices(LBound(long_indices)), ByVal VarPtr(GetArrayElement) + 8) If hresult = S_OK Then PutMem2 ByVal VarPtr(GetArrayElement), vt Case Else Err.Raise 5, , "Unsupported array element type" End Select If hresult <> S_OK Then Err.Raise hresult, , "Cannot get array element." End Function 

Using:

 Private Sub Command1_Click() Dim arrVariantByRef() As Variant ReDim arrVariantByRef(1 To 2, 1 To 3) Dim arrVariantNonByRef As Variant ReDim arrVariantNonByRef(1 To 2, 1 To 3) Dim arrOfLongs() As Long ReDim arrOfLongs(1 To 2, 1 To 3) Dim arrOfStrings() As String ReDim arrOfStrings(1 To 2, 1 To 3) Dim arrOfObjects() As Object ReDim arrOfObjects(1 To 2, 1 To 3) Dim arrOfDates() As Date ReDim arrOfDates(1 To 2, 1 To 3) arrVariantByRef(2, 3) = 42 arrVariantNonByRef(2, 3) = 42 arrOfLongs(2, 3) = 42 arrOfStrings(2, 3) = "42!" Set arrOfObjects(2, 3) = Me arrOfDates(2, 3) = Now MsgBox GetArrayElement(arrVariantByRef, 2, 3) MsgBox GetArrayElement(arrVariantNonByRef, 2, 3) MsgBox GetArrayElement(arrOfLongs, 2, 3) MsgBox GetArrayElement(arrOfStrings, 2, 3) MsgBox GetArrayElement(arrOfObjects, 2, 3).Caption MsgBox GetArrayElement(arrOfDates, 2, 3) End Sub 

I believe that you can easily build your logic with this base unit, although it may be slower than you want.
There are some type checks in the code that you can remove - then it will be faster, but you will need to make sure that you only pass arrays of the correct base type. You can also cache pArray and accept GetArrayElement accept that instead of the raw array.

Answer 2

My complete code is below, arr input is a 1, 2 or 3 dimensional array, 1 dimensional array returns 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 

Just check 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 

Answer 3

Now that I’ve written all this and realized that you will need a similar set of elements (based on SafeArrayPutElement instead of SafeArrayGetElement ) and the general procedure for creating an array , I think if this is really bad for hard coding all 60 cases.

The reason is that in the VBA array there can be no more than 60 measurements, and 60 cases it is not difficult to execute hardcode

I did not even enter this code, I used some Excel formulas to create 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, this is about twice as much as allowed in the message, so there is a link to the full version: http://pastebin.com/KVqV3vyU