Разбиение двумерного массива на несколько массивов, группируя строки по заданному столбцу

Sub test_SplitArray()
    ' считываем массив из 8 столбцов с активного листа
    arr = Range(Range("a2"), Range("a" & Rows.Count).End(xlUp)).Resize(, 8).Value
 
    ' разбиваем массив на несколько, по уникальным непустым значениям из первого столбца
    Dim coll As Collection: Set coll = SplitArray(arr, 1, "?*")
 
    ' перебираем отдельные массивы, выводим результаты
    For Each sarr In coll
        Debug.Print "Количество строк: " & UBound(sarr), "значение: """ & sarr(1, 1) & """"
    Next
End Sub

Function SplitArray(ByRef arr, ByVal SplitColumn&, Optional ByVal Mask$ = "*") As Collection
    On Error Resume Next: Err.Clear
    ' Функция принимает в качестве параметра arr двумерный массив,
    ' и разбивает его на несколько массивов, группируя строки по значению столбца SplitColumn&
    ' Сколько есть уникальных значений в столбце SplitColumn&, удовлетворяющих маске Mask$,
    ' - столько двумерных массивов будет возвращено функцией в виде коллекции
    Dim UB&: UB& = UBound(arr, 2)
    If Err <> 0 Or Not IsArray(arr) Then MsgBox "Исходные данные не являются двумерным массивом!", vbCritical, _
       "Ошибка в функции SplitArray": Exit Function
    If UB& < SplitColumn& Then MsgBox "В исходном массиве нет столбца с номером «" & SplitColumn& & "»!", vbCritical, _
       "Ошибка в функции SplitArray": Exit Function
 
    Dim coll As New Collection, UniqueValues As Object, txt$, i&, j&, uv, ind&, sarr
    Set SplitArray = New Collection
    Set UniqueValues = CreateObject("scripting.dictionary")
 
    ' ищем уникальные значения, подсчитывая количество строк по каждому уникальному значению
    For i = LBound(arr) To UBound(arr)
        txt$ = Trim$(arr(i, SplitColumn&))
        If txt$ Like Mask$ Then UniqueValues.Item(txt$) = Val(UniqueValues.Item(txt$)) + 1
    Next i
    For Each uv In UniqueValues.Keys        ' перебираем все найденные уникальные значения
        ind& = 0: ReDim sarr(1 To UniqueValues.Item(uv), LBound(arr, 2) To UBound(arr, 2))
        For i = LBound(arr) To UBound(arr)
            If Trim$(arr(i, SplitColumn&)) = uv Then
                ind& = ind& + 1        ' переносим очередную подходящую строку в подмассив
                For j = LBound(arr, 2) To UBound(arr, 2): sarr(ind&, j) = arr(i, j): Next j
            End If
        Next i
        SplitArray.Add sarr
    Next
End Function