Срезы массива VBA (не в Pythonic смысле)
Как мне реализовать эту функцию?
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) будет 2D массив 1x4. Выбранное измерение 2 было сглажено, и единственными оставшимися значениями являются те, которые изначально были в индексе 3 в измерении 2:
0
____
0| 3
1| 1
2| 2
3| 1
Как бы вы реализовали это в VBA? Единственные реализации, о которых я могу думать, будут включать CopyMemory, если я не ограничу количество допустимых измерений и жестко запрограммирован в каждом случае.
ПРИМЕЧАНИЕ. Вот как я могу получить размеры массива
ОБНОВИТЬ
Вот еще пара примеров работы
Для 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
Предположим, у меня был массив 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, а не в строках / столбцах)
Результат ArraySlice(array, 3, 1) будет массив 3х3х1
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) будет массив 3х3х1
0 1 2
0 ___________________
0| "001" "101" "201"
1| "011" "111" "211"
2| "021" "121" "221"
ЗАКЛЮЧИТЕЛЬНОЕ ОБНОВЛЕНИЕ
Вот полное решение - вы можете предположить, что функции Array реализованы так, как предлагает @GSerg в принятом ответе. Я решил, что имеет больше смысла полностью сглаживать нарезанное измерение, поэтому, если срез массива 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 ответа
Я не уверен, что полностью понимаю логику и связь между аргументами функции и результатом, но уже есть универсальная функция доступа к элементам, SafeArrayGetElement, Он позволяет получить доступ к элементу массива с неизвестными измерениями во время компиляции, все, что вам нужно, это указатель массива (только для справки; код в этом ответе был улучшен).
В отдельном модуле:
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
Использование:
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 принять это вместо необработанного массива.
Мой полный код приведен ниже, вход 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
Теперь, когда я написал все это и понял, что вам понадобится аналогичный элемент setter (основанный на SafeArrayPutElement вместо SafeArrayGetElement) и стандартная процедура создания массива, я думаю, действительно ли это плохо - жестко кодировать все 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