Функция принимает в качестве параметра arr двумерный массив, и разбивает его на несколько массивов, группируя строки по значению столбца SplitColumn&

Сколько есть уникальных значений в столбце SplitColumn&, удовлетворяющих маске Mask$, - столько двумерных массивов будет возвращено функцией в виде коллекции

Например, если есть исходный массив размерами 100*5, в котором во втором столбце есть 3 разных значения,
то функция SplitArray(arr, 3) вернёт коллекцию из 3 элементов - массивов размерами 25*5, 7*5, 68*5

Чтобы откинуть строки с пустыми значениями, можно применить маску "?*"
Можно взять только строки со сзначениями, начинающимися с цифры, содержащими текст "txt", - в этом случае, в параметр Mask$ надо передать строку "#*txt*"

Пример использования функции разделения массивов на несколько:

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

Код функции SplitArray:

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

• 9855 просмотров