VBA array slices (not in the Pythonic sense)

Question

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

Answer 1

Note: the code has been updated, the original version can be found in the revision history (not that it is useful to find it). The updated code does not depend on the undocumented GetMem* functions and is compatible with Office 64-bit.

I'm not sure I fully understand the logic and the connection between the function arguments and the result, but there already is a generic element accessor function, SafeArrayGetElement. It lets you access an element of an array with dimensions unknown at compile time, all you need is the array pointer.

In a separate module:

Option Explicit

#If VBA7 Then
  Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByRef Destination As Any, ByRef Source As Any, ByVal length As LongPtr)
  Private Declare PtrSafe Function SafeArrayGetElement Lib "oleaut32.dll" (ByVal psa As LongPtr, ByRef rgIndices As Long, ByRef pv As Any) As Long
  Private Declare PtrSafe Function SafeArrayGetVartype Lib "oleaut32.dll" (ByVal psa As LongPtr, ByRef pvt As Integer) As Long
#Else
  Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByRef Destination As Any, ByRef Source As Any, ByVal length As Long)
  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
#End If

Private Const VT_BYREF As Long = &H4000&
Private Const S_OK As Long = &H0&

' When declared in this way, the passed array is wrapped in a Variant/ByRef. It is not copied.
' Returns *SAFEARRAY, not **SAFEARRAY
#If VBA7 Then
Private Function pArrPtr(ByRef arr As Variant) As LongPtr
#Else
Private Function pArrPtr(ByRef arr As Variant) As Long
#End If
  'VarType lies to you, hiding important differences. Manual VarType here.
  Dim vt As Integer
  CopyMemory ByVal VarPtr(vt), ByVal VarPtr(arr), Len(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
    CopyMemory ByVal VarPtr(pArrPtr), ByVal VarPtr(arr) + 8, Len(pArrPtr)  'pArrPtr = arr->pparray;
    CopyMemory ByVal VarPtr(pArrPtr), ByVal pArrPtr, Len(pArrPtr)          'pArrPtr = *pArrPtr;
  Else
    'Non-by-ref variant array. Contains *parray at offset 8
    CopyMemory ByVal VarPtr(pArrPtr), ByVal VarPtr(arr) + 8, Len(pArrPtr)  'pArrPtr = arr->parray;
  End If
End Function


Public Function GetArrayElement(ByRef arr As Variant, ParamArray indices() As Variant) As Variant

#If VBA7 Then
  Dim pSafeArray As LongPtr
#Else
  Dim pSafeArray As Long
#End If

  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 CopyMemory ByVal VarPtr(GetArrayElement), ByVal VarPtr(vt), Len(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

Usage:

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 you can easily build your logic using this base block, although it might be slower than you want.
There are some type checks in the code which you can remove - then it will be faster, but you will have to make sure you only pass arrays of correct underlying type. You can also cache the pArray and make GetArrayElement accept that instead of a raw array.

Answer 2

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

Answer 3

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