Отфильтровать 2D-массив и разрезать на 1D

Массив, Словарь, 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