возможно ли создать коллекцию массивов в vba?

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

то, что я хочу сделать, – собрать идентификаторы в коллекциях для каждого округа. Наконец, я присоединяюсь к значениям в коллекциях с функцией Join и ";" в качестве разделителя, а затем распечатать их в диапазоне 4 столбцов в качестве списка поиска для каждого класса. Например;

Класс 2 (0) будет включать в себя 54020 и 30734, класс 2 (1) будет включать 58618, класс 1 (4) будет включать в себя нет, класс 3 (7) будет включать в себя 35516,34781 и 56874 и т. Д.

Я хочу, чтобы цикл через столбец C и поставить элемент выбора случае проверить класс, а затем назначить значения для коллекций

Sub dict_coll() Dim class1() As New Collection Dim class2() As New Collection Dim class3() As New Collection Dim class4() As New Collection Dim dict As New Scripting.Dictionary Set dRange = range(range("a2"), range("a2").End(xlDown)) i = 0 For Each d In dRange If Not dict.Exists(d.Value) Then dict.Add key:=d.Value, item:=i i = i + 1 End If Next d Set cRange = range(range("c2"), range("c2").End(xlDown)) For Each c In cRange Select Case c.Value Case "class1" class1(dict(c.offset(0,-2).value)).Add c.Offset(0, 1).Value 'fails here Case "class2" class2(dict(c.offset(0,-2).value)).Add c.Offset(0, 1).Value 'fails here Case "class3" class3(dict(c.offset(0,-2).value)).Add c.Offset(0, 1).Value 'fails here Case Else class4(dict(c.offset(0,-2).value)).Add c.Offset(0, 1).Value 'fails here End Select Next c End Sub 

введите описание изображения здесь

и то, что я хочу видеть, – это следующее: введите описание изображения здесь есть ли более простой и правильный способ того, что я хочу делать? любая помощь будет оценена.

благодаря

Я не видел, что переменная sb определена в вашем коде.

Во всяком случае, для меня я вижу случай с прямыми массивами: существует фиксированный размер классов, поэтому он достаточно хорош для меня. Кроме того, вы можете легко вернуться к рабочему листу.

 Public Sub test() Const strPrefix = "class" Dim districtRange As Range, outputRange As Range, r As Range Dim arr() As String Dim i As Long, j As Long, x As Long, y As Long Dim district As String, str As String, idVal As String Dim arr2 As Variant Application.ScreenUpdating = False ReDim arr(1 To 5, 1 To 1) arr(1, 1) = "District" arr(2, 1) = "Class 1" arr(3, 1) = "Class 2" arr(4, 1) = "Class 3" arr(5, 1) = "Class 4" Set districtRange = Range(Range("A2"), Range("C2").End(xlDown)) arr2 = districtRange.Value For x = LBound(arr2, 1) To UBound(arr2, 1) district = arr2(x, 1) i = Val(Mid(arr2(x, 3), Len(strPrefix) + 1)) idVal = arr2(x, 2) j = inArray(arr, district, 1) 'returns -1 if not found If j >= 0 Then arr(i + 1, j) = IIf(arr(i + 1, j) = "", idVal, arr(i + 1, j) & ";" & idVal) Else ReDim Preserve arr(1 To 5, 1 To UBound(arr, 2) + 1) arr(1, UBound(arr, 2)) = district arr(i + 1, UBound(arr, 2)) = idVal End If Next x Set outputRange = Range("E1") outputRange.Resize(UBound(arr, 2), UBound(arr, 1)).Value = Application.Transpose(arr) outputRange.Sort Key1:=Range("E1"), Header:=xlYes, Order1:=xlAscending Application.ScreenUpdating = True End Sub Public Function inArray(arr As Variant, k As String, Optional rowNum As Long, Optional colNum As Long) As Long Dim i As Long, j As Long inArray = -1 If rowNum Then For i = LBound(arr, 2) To UBound(arr, 2) If arr(rowNum, i) = k Then inArray = i Exit Function End If Next i Else For i = LBound(arr, 1) To UBound(arr, 1) If arr(i, colNum) = k Then inArray = i Exit Function End If Next i End If End Function 

кстати, я нашел другое решение, используя как словарь, так и 3-мерный массив.

 Sub test() Dim Blg As New Scripting.Dictionary Dim Sgm As New Scripting.Dictionary Dim Siciller() As String ReDim Siciller(0 To 23, 0 To 3, 0 To 5) Set alanBolge = range(range("a2"), range("a2").End(xlDown)) Set alanSegment = range(range("c2"), range("c2").End(xlDown)) i = 0 For Each d In alanBolge If Not Blg.Exists(d.Value) Then Blg.Add Key:=d.Value, item:=i i = i + 1 End If Next d k = 0 For Each d In alanSegment If Not Sgm.Exists(d.Value) Then Sgm.Add Key:=d.Value, item:=k k = k + 1 End If Next d 'data reading For Each d In alanBolge Siciller(Blg(d.Value), Sgm(d.Offset(0, 2).Value), dolusay(Siciller, Blg(d.Value), Sgm(d.Offset(0, 2).Value)) + 1) = d.Offset(0, 1).Value Next d 'output For x = 1 To 4 For y = 1 To 24 Set h = Cells(1 + y, 5 + x) h.Select h.Value = sonucgetir(Siciller, Blg(h.Offset(0, -x).Value), Sgm(h.Offset(-y, 0).Value)) Next y Next x End Sub Public Function dolusay(ByVal data As Variant, ByVal i1 As Integer, ByVal i2 As Integer) As Integer Dim count As Integer count = 0 For j = 0 To UBound(data, 3) - 1 If Len(data(i1, i2, j)) > 0 Then count = count + 1 End If Next dolusay = count End Function Public Function sonucgetir(ByVal data As Variant, ByVal i1 As Integer, ByVal i2 As Integer) As String sonucgetir = "" For i = 0 To UBound(data, 3) If Len(data(i1, i2, i)) > 0 Then x = data(i1, i2, i) & ";" & x sonucgetir = Left(x, Len(x) - 1) End If Next i End Function 
Interesting Posts

Автоматическое увеличение в vb.net

Создание диаграммы области стека, которая показывает проблемы во времени с использованием начальных и конечных дат

Диапазон в формуле Excel изменяется после смены вставки, как я могу остановить его изменение?

Пользовательская форма VBA не заполняется при первом открытии, но работает во второй раз

Excel импортирует данные SQL, но изменяет порядок 1 столбца после импорта

Excel индекс (совпадение)

Как получить последнее слово в ячейке с помощью формулы Excel

Чтение определенных полей из пространственной записи в Access 2010 из Excel 2010

Заказ на печать коллекции jxls

Excel – что-то между match / substring / left / find

VBA Excel autofiltermode = false, не отключая автофильтр

Попытка использовать UDF .xll для параллелизации Excel в сетке HPC

Вызов ячейки, чья строка – это содержимое другой ячейки

Как добавить гиперссылку в ячейку на листе с помощью office-js без использования гиперссылки fomula?

VBA – параметр рабочего листа в функции

Давайте будем гением компьютера.