过滤二维阵列并将其切片到一维

Question

有一个包含3列的导入数组：

​

​

目标是通过一个值(例如"1")对第三列进行过滤，并将一个一维数组返回给一个UDF-Excel-公式。我的代码中有一些问题：

1.1)是否有更好的方法缩短代码？做很多类似的循环。

1.2)由于Excel表格中有许多公式，因此代码将多次运行。我是否可以至少避免使用UBounds来计算起源-2D-数组的长度(因为它们将始终保持不变)？

1. 代码不到达"fArray = arr1D“。所以它不会写任何回音。有人能帮忙吗？谢谢。

在将Excel的值导入2D-Array之后，我的部分代码：

Function fArray(ArrName As String, Optional Gruppe As Byte)

Dim arr As Variant, arr1D as Variant
Dim i as long, j as Long, c as long

    'Count Matches
    For i = LBound(arr, 1) To UBound(arr, 1)
        If arr(i, 3) = Gruppe Then           'Filter
            c = c + 1
        End If
    Next i
    
    'If no Match exit
    If c = 0 Then
        Exit Function
    End If
    
    ReDim arr1D(1 To c, 1 To 1)         

    'Generate new filtered Array    
    For i = 1 To UBound(arr, 1)
        If arr(i, 1) > 1 Then
            j = j + 1
            arr1D(j, 1) = arr(i, 1)         'Assign and Slice from 2D to 1D
            
        End If
    Next i
    
    fArray = arr1D                          'Write back to Excel-Formula (UDF)
    
End Function

Answer 1

数组，字典，ArrayList

• TESTfArray测试您的函数fArray。
• fArray展示了在您的情况下如何使用以下三个函数。
• vLookupArray、vLookupDictionary和vLookupArrayList给出了三种解决方案。他们基本上也是这么做的。所有解决方案将返回一个一维数组。vLookupArray将返回一个基于一个的数组，而其他两个解决方案将返回基于零的数组.哪个更有效率取决于你自己。
• TESTvLookup将测试所有三个函数。
• 了解Dictionary对象这里、这里和这里，以及ArrayList 这里和这里。

代码

Option Explicit

Sub TESTfArray()
    Dim arr As Variant
    arr = fArray("NamedRangeName", 1)
    If Not IsEmpty(arr) Then
        Debug.Print Join(arr, vbLf)
    End If
End Sub

Function fArray(ArrName As String, Optional Gruppe As Byte) As Variant
    
    Dim arr As Variant
    
    ' Code to get 'arr' from ArrName.
    ' e.g.:
    arr = Range(ArrName).Value
    'arr = Range("A1").CurrentRegion
    
    If Not IsEmpty(arr) Then
        fArray = vLookupArray(arr, Gruppe, 3, 1)
        'fArray = vLookupDictionary(arr, Gruppe, 3, 1)
        'fArray = vLookupArrayList(arr, Gruppe, 3, 1)
    End If

End Function

Function vLookupArray(TwoD As Variant, _
    ByVal LookupValue As Variant, _
    ByVal LookupColumn As Long, _
    ByVal ReturnColumn As Long) _
As Variant
    Dim rCount As Long: rCount = UBound(TwoD, 1)
    Dim OneD As Variant: ReDim OneD(1 To rCount)
    Dim i As Long
    Dim n As Long
    For i = 1 To rCount
        If TwoD(i, LookupColumn) = LookupValue Then
            n = n + 1
            OneD(n) = TwoD(i, ReturnColumn)
        End If
    Next i
    If n > 0 Then
        ReDim Preserve OneD(1 To n)
        vLookupArray = OneD
        'Debug.Print "Array:" & vbLf & Join(vLookupArray, vbLf)
    End If
End Function

' Dictionary: Item, Count, Keys
Function vLookupDictionary(TwoD As Variant, _
    ByVal LookupValue As Variant, _
    ByVal LookupColumn As Long, _
    ByVal ReturnColumn As Long) _
As Variant
    With CreateObject("Scripting.Dictionary")
        Dim i As Long
        For i = 1 To UBound(TwoD, 1)
            If TwoD(i, LookupColumn) = LookupValue Then
                .Item(TwoD(i, ReturnColumn)) = Empty
            End If
        Next i
        If .Count > 0 Then
            vLookupDictionary = .Keys
           'Debug.Print "Dictionary:" & vbLf & Join(vLookupDictionary, vbLf)
        End If
    End With
End Function

' ArrayList: Add, Count, ToArray
Function vLookupArrayList(TwoD As Variant, _
    ByVal LookupValue As Variant, _
    ByVal LookupColumn As Long, _
    ByVal ReturnColumn As Long) _
As Variant
    With CreateObject("System.Collections.ArrayList")
        Dim i As Long
        For i = 1 To UBound(TwoD, 1)
            If TwoD(i, LookupColumn) = LookupValue Then
                .Add TwoD(i, ReturnColumn)
            End If
        Next i
        If .Count > 0 Then
            vLookupArrayList = .ToArray
            'Debug.Print "ArrayList:" & vbLf & Join(vLookupArrayList, vbLf)
        End If
    End With
End Function

Sub TESTvLookup()
    Dim cel As Range
    Set cel = Range("A2")
    Dim rng As Range
    With cel.CurrentRegion
        Set rng = cel.Resize( _
            .Rows.Count + .Row - cel.Row, _
            .Columns.Count + .Column - cel.Column)
    End With
    Debug.Print "Range Address:" & vbLf & rng.Address(0, 0)
    Dim TwoD As Variant
    TwoD = rng.Value
    Dim OneD As Variant
    OneD = vLookupArray(TwoD, 1, 3, 1)
    If Not IsEmpty(OneD) Then
        Debug.Print "Array:" & vbLf & Join(OneD, vbLf)
    End If
    OneD = vLookupDictionary(TwoD, 1, 3, 1)
    If Not IsEmpty(OneD) Then
        Debug.Print "Dictionary:" & vbLf & Join(OneD, vbLf)
    End If
    OneD = vLookupArrayList(TwoD, 1, 3, 1)
    If Not IsEmpty(OneD) Then
        Debug.Print "ArrayList:" & vbLf & Join(OneD, vbLf)
    End If
End Sub