从多维数组中提取用户定义的维度

Question

我需要一个函数来从多维数组中提取二维。根据用户的选择提取哪两个维度。以及丢弃维度中的索引，这两个维度的选择也取决于用户。

例如，我有一个 3 维数组 v（1 到 100、1 到 20、1 到 10）。我想从 v 中提取维度 1 和维度 3，并且丢弃维度 2 中的索引为 11。

sub extract
dim i1 as integer 'for loop through dimension 1
dim i2 as integer 'for loop through dimension 3
dim d1 as integer 'index in dimension 2
d1=11
redim vn(1 to ubound(v,1),1 to ubound (v,3))
for i1 = 1 to ubound(v,1)
    for i2= 1 to ubound(v,3)
        vn(i1,i2)=v(i1,d1,i2)
    next i2
next i1
end sub

如果我知道我需要哪些维度以及丢弃维度中的索引 (d1)，我可以从数组中提取维度。但是，我需要让用户来决定。我想要的是这样的功能：

function extract(i1 as integer, i2 as intger, paramarray ov()) as variant

=extract(the_first_dimension_to_keep,the_second_dimension_to_keep,[index_in_the_first_discard_dimension,index_in_the_second_discard_dimension,...])

请记住，原始数组可以有超过 3 个维度，因此无法在代码中列出所有可能性。

有什么解决办法吗？

Answer 1

最快的方法是使用指针读取数组，并根据每个维度的数量和元素数量将指针值增加一个算法值。这个站点有一个关于管理数组指针的优秀教程：http://bytecomb.com/vba-internals-getting-pointers。但是，这将是一项艰巨的编码任务-只需为内存读取确定SAFEARRAY 的rgabounds 的尺寸将是一项任务-如果您的数组值为Strings，它将是一个数量级更强大。

一个更简单但无疑更慢的选项是利用For Each 循环方法，该方法可以应用于数组。它的循环顺序是这样的：

arr(1,1)
arr(2,1)
arr(3,1)
arr(1,2)
arr(2,2)
arr(3,2)
etc.

所以你只需要一个简单的里程表式索引计数器。

您基本上可以迭代数组中的每个元素，如果索引组合与您想要的匹配，您可以将元素读入提取数组。那将是一项容易得多的任务。下面的代码向您展示了如何在未知维度的多维数组上执行此操作。

Option Explicit
Private Type ArrayBounds
    Lower As Long
    Upper As Long
    Index As Long
    WantedDimension As Boolean
    DiscardIndex As Long
End Type
Public Sub RunMe()
    Dim arr As Variant
    Dim result As Variant

    arr = CreateDummyArray
    result = Extract(arr, 1, 3, 11)

End Sub
Private Function Extract(arr As Variant, i1 As Integer, i2 As Integer, ParamArray ov() As Variant) As Variant
    Dim d As Long
    Dim bounds() As ArrayBounds
    Dim i As Long
    Dim v As Variant
    Dim ovIndex As Long
    Dim doExtract As Boolean
    Dim result() As Variant

    'Dimension the output array
    ReDim result(LBound(arr, i1) To UBound(arr, i1), LBound(arr, i2) To UBound(arr, i2))

    'Get no. of dimensions in array
    d = GetDimension(arr)

    'Now we know the number of dimensions,
    'we can check that the passed parameters are correct
    If (i1 < 1 Or i1 > d) Or (i2 < 1 Or i2 > d) Then
        MsgBox "i1/i2 - out of range"
        Exit Function
    End If

    If UBound(ov) - LBound(ov) + 1 <> d - 2 Then
        MsgBox "ov - wrong number of args"
        Exit Function
    End If

    'Resise and populate the bounds type array
    ReDim bounds(1 To d)
    ovIndex = LBound(ov)
    For i = 1 To d
        With bounds(i)
            .Lower = LBound(arr, i)
            .Upper = UBound(arr, i)
            .Index = .Lower
            .WantedDimension = (i = i1) Or (i = i2)
            If Not .WantedDimension Then
                .DiscardIndex = ov(ovIndex)
                ovIndex = ovIndex + 1
                'Check index is in range
                If .DiscardIndex < .Lower Or .DiscardIndex > .Upper Then
                    MsgBox "ov - out of range"
                    Exit Function
                End If
            End If
        End With
    Next

    'Iterate each member of the multi-dimensional array with a For Each
    For Each v In arr
        'Check if this combination of indexes is wanted for extract
        doExtract = True
        For i = 1 To d
            With bounds(i)
                If Not .WantedDimension And .Index <> .DiscardIndex Then
                    doExtract = False
                    Exit For
                End If
            End With
        Next

        'Write value into output array
        If doExtract Then
            result(bounds(i1).Index, bounds(i2).Index) = v
        End If

        'Increment the dimension index
        For i = 1 To d
            With bounds(i)
                .Index = .Index + 1
                If .Index > .Upper Then .Index = .Lower Else Exit For
            End With
        Next

    Next

    Extract = result
End Function
Private Function GetDimension(arr As Variant) As Long
    'Helper function to obtain number of dimensions
    Dim i As Long
    Dim test As Long

    On Error GoTo GotIt
    For i = 1 To 60000
        test = LBound(arr, i)
    Next
    Exit Function
GotIt:
    GetDimension = i - 1
End Function