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

Функция принимает в качестве параметра 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

Комментарии

Настройки просмотра комментариев

Выберите нужный метод показа комментариев и нажмите "Сохранить установки".

Сергей, я не консультирую по бесплатным макросам.
Вашего массива данных я не видел, и что из него получить надо, - тоже не знаю.
Потому, вряд ли чем смогу помочь.

У меня ест массив данных, поясните пожалуйста на пальцах, как мне применить на него этот макрос.

Премного благодарен!!! шикарная штука!!!)))

например, так:

' перебираем отдельные массивы, выводим результаты
For Each sarr In coll
    ' для каждого массива создаем новый лист - и туда выводим данные
    Worksheets.Add.Range("a1").Resize(UBound(sarr, 1), UBound(sarr, 2)).Value = sarr
Next

Здравствуйте, а как же вывести все значения получившихся новых массивов, например на рабочий лист?

Всё правильно у вас написано, - должно работать.

как достать часть разбитого ранее массива из коллекции и положить в массив? sarr(1, 1)- не работает.
Нужно arr = coll.item(1)-- где ошибка?

Как раз то что я искал. А вот, этот оператор SplitArray.Add sarr не понял. Поясните пожалуйста.

Отправить комментарий

Содержание этого поля является приватным и не предназначено к показу.
CAPTCHA
Подтвердите, пожалуйста, что вы - человек:
  ____    _     _  _     _____   _____    __ 
| _ \ | |_ | || | | ____| |___ | / _|
| | | | | __| | || |_ | _| / / | |_
| |_| | | |_ |__ _| | |___ / / | _|
|____/ \__| |_| |_____| /_/ |_|
Введите код, изображенный в стиле ASCII-арт.

Не получается применить макрос? Не удаётся изменить код под свои нужды?

Оформите заказ у нас на сайте, не забыв прикрепить примеры файлов, и описать, что и как должно работать.