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