Arrays VBA数组切片（不是Python意义上的）

我应该如何实现此功能？

Public Function ArraySlice(arr As Variant, dimension as Long, index as Long) As Variant

    'Implementation here

End Function

假设我想要一个数组的切片。我指定了一个数组、一个维度和一个关于该维度的索引，我希望为其创建切片

作为一个具体的例子，假设我有以下5x42D数组

   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

如果水平维度为1，垂直维度为2，

ArraySlice（array，1，3）

的返回值将为1x4 2D数组。选定的维度2已展平，唯一剩余的值是最初位于维度2索引3处的值：

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

如何在VBA中实现这一点？我所能想到的唯一实现将涉及CopyMemory，除非我限制允许的维度数量并对每种情况进行硬编码

注:

更新

下面是更多的操作示例

对于二维阵列

   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

ArraySlice（array，2，2）

的结果将是

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

假设我有一个3x3x3数组，由以下二维切片组成 此示例已更改为更清晰

（如此构造）

（尺寸用于数学x、y、z方向，与行/列方向相反）

ArraySlice（array，3，1）

的结果将是3x3x1数组

     0  1  2
0   _________
  0| 4  4  4  
  1| 5  5  5  
  2| 6  6  6 

       0     1     2
0   ___________________
  0| "001" "101" "201"  
  1| "011" "111" "211"
  2| "021" "121" "221"

ArraySlice（array，2，2）

的结果将是3x1x3数组

     0  1  2        0  1  2         0  1  2
0   _________   1   _________  2   _________
  0| 3  3  3      0| 6  6  6     0| 9  9  9

更新2

对于DavidZemens而言，以下是一个可以更轻松地跟踪相关元素的示例：

对于这样构造的3x3x3阵列

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

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"

ArraySlice（array，3，1）

的结果将是3x3x1数组

     0  1  2
0   _________
  0| 4  4  4  
  1| 5  5  5  
  2| 6  6  6 

       0     1     2
0   ___________________
  0| "001" "101" "201"  
  1| "011" "111" "211"
  2| "021" "121" "221"

最终更新

这里是完整的解决方案-您可以假设数组函数是按照@GSerg在接受的答案中建议的方式实现的。我认为完全展平切片的维度更有意义，因此如果3x3x3数组（“立方体”）的切片是3x1x3，它将展平为3x3。我仍然需要解决这样一种情况：用这种方法展平一维数组将产生一个0维数组

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

公共函数ArraySlice（arr为变量，维度为长，索引为长）为变量
'TODO:断言arr是数组
'TODO:断言维度有效
'TODO:断言索引有效
Dim arrDims作为整数
arrDims=GetArrayDim（arr）'N维
类型为整数
arrType=GetArrayType（arr）
Dim zeroIndexedDimension作为整数
zeroIndexedDimension=dimension-1'通过减去1将维度索引为零，以便于数学计算
Dim newArrDims作为整数
newArrDims=arrDims-1'N-1个维度，因为我们正在“索引”上展平“维度”
Dim arrDimSizes（）作为变量
Dim newArrDimSizes（）作为变量
ReDim arrDimSizes（0到arrDims-1）
ReDim NEWARDIMSIZES（0到NEWARDIMS-1）
我想我会坚持多久
对于i=0到arrDims-1
arrDimSizes（i）=UBound（arr，i+1）-LBound（arr，i+1）+1
下一个
'获取原始对象的每个对应维度的大小
对于i=0到零索引尺寸-1
新arrDimSizes（i）=arrDimSizes（i）
下一个
跳过“维度”，因为我们正在将其展平
'获取剩余的尺寸，按1进行偏移
对于i=ZeroIndexedArrdims-2的尺寸
新arrDimSizes（i）=arrDimSizes（i+1）
下一个
Dim newArray作为变体
newArray=CreateArray（arrType、newArrDims、newArrDimSizes）
'遍历维度，复制
Dim arrcuindices（）作为变体
Dim newarrcuindices（）作为变体
ReDim arrcuindicates（0到arrDims-1）
ReDim newArrDims（0到newArrDims-1）
arrcuindices（zeroIndexedDimension）=索引“这是切片
趁我还活着
'复制元素
PutArrayElement新数组，GetArrayElement（arr，arrcuindices），Newarrcuindices
'将两个数组迭代到下一个位置
如果不增加索引（arrcuindices、arrDimSizes、zeroIndexedDimension），则
'如果我们复制了所有元素
退出Do
如果结束
递增索引newarrcuindices，newarrdimsize
环
ArraySlice=newArray
端函数
私有函数incrementIndex（arrIndexes作为变量，arrDimensionSizes作为变量，可选zeroIndexedDimension作为整数=-2）作为布尔值
'IncrementArray根据arrDimensionSizes中的大小顺序迭代所有有效索引
'例如，假设重复调用该函数，起始索引为[0,0,0]，arrDimensionSizes为[3,1,3]。
“结果将如下所示：
“[0,0,0]第一次呼叫
'[0, 0, 1]
'[0, 0, 2]
'[1, 0, 0]
'[1, 0, 1]
'[1, 0, 2]
'[2, 0, 0]
'[2, 0, 1]
'[2, 0, 2]
'可选的“dimension”参数允许冻结维度，并且不包括在迭代中。
'例如，假设重复调用该函数，起始索引为[0,1,0]，arrDimensionSizes为[3,3,3]，维度为2
“[0,1,0]第一次呼叫
'[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=UBound（arrCurDimension）
'如果此维度为“已满”或是冻结维度，请跳过该维度以查找进位
而ArrIndexes（arrCurDimension）=arrDimensionSizes（arrCurDimension）-1或arrCurDimension=zeroIndexedDimension
“携带
arrCurDimension=arrCurDimension-1
如果arrCurDimension=-1，则
递增索引=假
退出功能
如果结束
温德
ArrIndexes（arrCurDimension）=ArrIndexes（arrCurDimension）+1
当arrCurDimension

没有

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

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

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

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