VBA数组切片(不是Pythonic意义上的)

时间:2015-09-09 19:50:01

标签: arrays vba

我应该如何实现此功能?

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

    'Implementation here

End Function

假设我想要一个数组切片。我在该维度上指定了一个数组,一个维度和一个索引,我想要切片。

作为一个具体的例子,假设我有以下5x4 2D数组

   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,除非我限制了允许的维数和每个案例的硬编码。

注意:Here is how I would get the dimensions of the array

更新

以下是一些操作的例子

对于2D数组

   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

假设我有一个由以下2维切片组成的3x3x3阵列 此示例已更改为更清晰

     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

(如此构建)

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

(尺寸用于数学x,y,z意义而不是行/ cols意义)

ArraySlice(array, 3, 1)的结果是3x3x1数组

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

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

UPDATE2

对于DavidZemens,这里有一个例子,可以更容易地跟踪所涉及的元素:

对于像这样构造的3x3x3阵列

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| "001" "101" "201"  
  1| "011" "111" "211"
  2| "021" "121" "221"

最终更新

以下是完整的解决方案 - 您可以假设在接受的答案中,@ GSerg建议实现Array函数。我认为完全展平切片尺寸更有意义,因此如果3x3x3阵列(“立方体”)的切片为3x1x3,则会变平至3x3。我仍然需要解决这种情况,即通过这种方法展平1维数组会产生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

3 个答案:

答案 0 :(得分:5)

  

注意:代码已更新,原始版本可在revision history中找到(并非找到它有用)。更新的代码不依赖于未记录的GetMem*函数,并且与Office 64位兼容。

我不确定我是否完全理解函数参数和结果之间的逻辑和连接,但是已经存在通用元素访问器函数SafeArrayGetElement。它允许您在编译时访问维度未知的数组元素,您只需要array pointer

在另一个模块中:

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

用法:

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

我相信您可以使用此基本块轻松构建逻辑,尽管它可能比您想要的慢 您可以删除代码中的某些类型检查 - 然后它会更快,但您必须确保只传递正确的基础类型的数组。您也可以缓存pArray并使GetArrayElement接受而不是原始数组。

答案 1 :(得分:3)

我的完整代码如下,arr输入是1,2或3维数组,1维数组将返回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


只需通过以下代码进行测试

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

答案 2 :(得分:1)

现在我写了all this并意识到你需要一个类似的元素设置器(基于SafeArrayPutElement而不是SafeArrayGetElement)和一个通用array creation routine,我是思考对所有60个案件进行硬编码是否真的是一件坏事。

原因是VBA阵列中最多可以有60个维度,60个难以硬编码

我甚至没有输入此代码,我使用了一些Excel公式来生成它:

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

不幸的是,它比帖子中允许的时间长两倍,所以有一个指向完整版的链接:http://pastebin.com/KVqV3vyU