Добрый день! Не могу сообразить как работать с многомерным массивом, есть исходная таблица, она обработана через словарь. где номер строки это ключ, значение = двумерный массив. На выходе надо получить для каждого уникального значения в первом столбце(1,1) (желтым в целевой таблице), массив без дубликатов из строк, в которых первый столбец ключевой. В целевой таблице, это то, что должно получиться в итоговом массиве для каждой записи в словаре. Нужно именно в словаре, не в коллекции. Не получается именно создать многомерный массив, и заполнить его корректно. Плюс обработать записи в массиве, чтобы не было совпадений. Цель, получить в словаре ключ из первого столбца, и массив включая сам первый столбец, с уникальными для первого столбца записями. Возможно я не в ту сторону рою, и многомерный массив тут не нужен.
Sub aaa()
Dim arr(), cc(), dd(), a&, b&, c&, d&, DC As New Scripting.Dictionary, kk
With Sheets(1)
.Columns("J:O").Rows("2:" & .UsedRange.Rows.Count).Clear
arr = Intersect(.[a2].CurrentRegion, .Rows("2:" & .Cells(.Rows.Count, 2).End(xlUp).Row)).Value
For a = 1 To UBound(arr)
If Not DC.Exists(arr(a, 1)) Then
ReDim dd(1 To 1): dd(1) = a: DC.Add arr(a, 1), dd
Else
dd = DC.Item(arr(a, 1)): ReDim Preserve dd(1 To UBound(dd) + 1)
dd(UBound(dd)) = a: DC.Item(arr(a, 1)) = dd
End If
Next
dd = DC.Items: b = 2: a = 0
ReDim cc(1 To UBound(arr), 1 To UBound(arr, 2) - 1)
For Each kk In DC.Keys
With .Cells(b, 10)
.NumberFormat = "@": .Value = kk: .Borders.LineStyle = 9
End With
For c = 1 To UBound(dd(a))
For d = 2 To UBound(arr, 2)
cc(b - 1, d - 1) = arr(dd(a)(c), d)
Next
b = b + 1
Next
a = a + 1
Next
With .Cells(2, 11).Resize(UBound(cc), UBound(cc, 2))
.NumberFormat = "@": .Borders.LineStyle = 1: .Value = cc
End With
End With
Set DC = Nothing
End Sub
Доброе время суток. Anchoret, не уловил. Результат никак не сбивается с тем, что должно быть на выходе у ТС на листе. Updated Версия на Power Query. P. S. Судя по выводу ТС нужно для каждого уникального значения столбца один, оставить в каждом столбце от 2 до 6 только уникальные значения.
Mergens,так вся строка является критерием уникальности помимо первой ячейки строки, или какие-то отдельные элементы этой строки? Если уники искать по всем столбцам, то это жесть) ------ Действительно по всем столбцам...
Anchoret написал: вся строка является критерием уникальности помимо первой ячейки строки, или какие-то отдельные элементы этой строки?
Добрый день! Андрей правильно ответил. Первый столбец уникален и является ключем для словаря ld.Key, в словарь надо положить массив в котором будут лежать только уникальные значения с первого(он тоже нужен,) по 6 столбец ld.Items. Таким образом получается, что для каждого уникального значения из столбца 1, собирается массив = сам 1 столбец уникальный(всегда 1 запись), 2 столбец(уникальные записи, для 1го), 3 столбец(уникальные для 1го), 4 столбец(уникальные для 1го) и т.д.
В файле сделал целевую область, это именно то, что должно лежать в массиве на выходе, после прохода всех строчек.
Андрей VG, изначально пошел не по тому пути + пропустил часть описания задачи. Но на этом не остановился и стал искоренять все дубли по столбцам по каждому опорному значению в столбце "А". В общем сам себе придумал квест, а потом глянул третий раз на искомый результат в файле-примере и понял что занимался всем этим зря) Не мой день...
Ну и раз написал черт знает что, то вдруг такое глобальное искоренение дублей кому нужно... Вот:
Скрытый текст
Код
Sub bbb()
Dim dd(), a&, b&, c&, d&, i&, j&, DC As New Scripting.Dictionary, dt$, arr()
Dim aa As Range, bb As Range, cc As Range, mm(), mtrx(), zz(), ff As Boolean
With Sheets(1)
.Columns("J:O").Rows("2:" & .UsedRange.Rows.Count).Clear
Set aa = Intersect(.[a2].CurrentRegion, .Rows("2:" & .Cells(.Rows.Count, 2).End(xlUp).Row))
For a = 1 To aa.Rows.Count
If Not DC.Exists(aa(a, 1).Value) Then
Set bb = aa.Range(Cells(a, 2), Cells(a, aa.Columns.Count))
DC.Add aa(a, 1).Value, bb.Address
Else
Set bb = aa.Range(Cells(a, 2), Cells(a, aa.Columns.Count))
Set bb = Union(.Range(DC.Item(aa(a, 1).Value)), bb): DC.Item(aa(a, 1).Value) = bb.Address
End If
Next
b = 2: dd = DC.Keys: c = 0: arr = DC.Items
For a = 0 To UBound(dd)
With .Cells(b, 10)
.NumberFormat = "@": .Value = dd(a): .Borders.LineStyle = 9
End With
Set cc = .Range(arr(a)): mm = cc.Value
ReDim mtrx(1 To cc.Columns.Count)
For d = 1 To cc.Rows.Count
If c = 0 Then
Set bb = Intersect(cc, cc.Rows(d)): c = 1: ReDim zz(1 To 1)
For j = 1 To UBound(mm, 2): zz(1) = mm(d, j): mtrx(j) = zz: Next
Else
ff = False
If Not IsArray(mtrx(1)) Then
ReDim zz(1 To 1)
For j = 1 To UBound(mtrx): zz(1) = mm(d, j): mtrx(j) = zz: Next
Set bb = Union(bb, Intersect(cc, cc.Rows(d)))
Else
For i = 1 To UBound(mm, 2)
For z = 1 To UBound(mtrx(i))
If mm(d, i) = mtrx(i)(z) Then ff = True: Exit For
Next
If ff Then Exit For
Next
If Not ff Then
Set bb = Union(bb, Intersect(cc, cc.Rows(d)))
For i = 1 To UBound(mm, 2)
zz = mtrx(i): ReDim Preserve zz(1 To UBound(zz) + 1)
zz(UBound(zz)) = mm(d, i): mtrx(i) = zz
Next
End If
End If
End If
Next
b = b + UBound(mtrx(1))
Next
bb.Copy .[K2]
Intersect(.[K2].CurrentRegion, .Columns("K:O").Rows("2:" & .Cells(.Rows.Count, "K").End(xlUp).Row)).Borders.LineStyle = 1
End With
Set DC = Nothing
End Sub
собрать уникальные значения, которые по определению понятия "уникальный" уникальными не являются собрать уникальные, которые на самом деле совсем не уникальные эту задачу решаем?
Ну вроде да, если я правильно Вас понял, удалить все дубли для первого столбца, в последующих столбцах. первый столбец есть ключ, по которому определяется область из которой удалять дубли со 2го по 6ой столбцы.
Anchoret, точно сегодня надо завязывать с форумом))) у вас в результате только первая строка с ключем. В исходном файле указан тот результат, что должен получиться на выходе.
Андрей VG Хотел сказать Спасибо. очень помогли. возникла теперь потребность в том чтобы, получать конкретный словарь в из коллекции словарей по ключу после обработки всего массива.
Например: для ключа 10010394, получить словарь по номеру 3 со всеми значениями из FUniques() и т.д из другой процедуры.
Я расширил процедуру Create, передаю массив и принимаю сформированный словарь
Код
'----------------------------------------------------------------------------------------------------
Public Sub Create(ByVal byArray As Variant, FUItems As Scripting.Dictionary)
Dim curItem As UniqueItem, iRow As Long, iCol As Long
Set FUniqueItems = New Scripting.Dictionary
FColumnCount = UBound(byArray, 2) - 1
For iRow = 1 To UBound(byArray, 1)
Set curItem = GetUniqueItem(byArray(iRow, 1))
For iCol = 2 To UBound(byArray, 2)
curItem.Append iCol - 1, CStr(byArray(iRow, iCol))
Next
Next
Set FUItems = FUniqueItems
End Sub
похожу циклом по полученному словарю
Код
Sub FUSelect(FUItems as Scripting.Dictionary, ld as Scripting.Dictionary)
Dim sKey
Set ld = new Scripting.Dictionary
For Each sKey in FUItems.Keys
Call FUGetDic(FUItems(sKey), 2, ld) 'пытаемся получить внутренний словарь с кодом
Next
End Sub
но никак не могу получить внутренние словари по ключу.
Код
Sub FUGetDic(FUItems as Object, lKey as Integer, FUDic as Scripting.Dictionary)
Set FUDic = FUItems.FUniques(lKey)
End sub
Sub bbb()
Dim dd(), a&, b&, c&, d&, i&, j&, DC As New Scripting.Dictionary, arr()
Dim aa(), bb(), mm(), mtrx(), zz(), ff As Boolean, z&
With Sheets(1)
.Columns("J:O").Rows("2:" & .UsedRange.Rows.Count).Clear
aa = Intersect(.[a2].CurrentRegion, .Rows("2:" & .Cells(.Rows.Count, 2).End(xlUp).Row)).Value
For a = 1 To UBound(aa)
If Not DC.Exists(aa(a, 1)) Then
ReDim bb(1 To 1): bb(1) = .Range(Cells(a + 1, 2), Cells(a + 1, UBound(aa, 2))).Value
DC.Add aa(a, 1), bb
Else
bb = DC.Item(aa(a, 1)): ReDim Preserve bb(1 To UBound(bb) + 1)
bb(UBound(bb)) = .Range(Cells(a + 1, 2), Cells(a + 1, UBound(aa, 2))).Value
DC.Item(aa(a, 1)) = bb
End If
Next
b = 2: dd = DC.Keys: arr = DC.Items
ReDim mm(1 To UBound(aa, 2) - 1, 1 To 1)
For a = 0 To UBound(dd)
With .Cells(b, 10)
.NumberFormat = "@": .Value = dd(a): .Borders.LineStyle = 9
End With
bb = arr(a): z = 0
ReDim mtrx(1 To UBound(aa, 2) - 1)
For d = 1 To UBound(bb)
If Not IsArray(mtrx(1)) Then
ReDim zz(1 To 1)
For j = 1 To UBound(mtrx): zz(1) = bb(d)(1, j): mtrx(j) = zz: Next: z = 1
Else
For i = 1 To UBound(aa, 2) - 1
ff = False
For j = 1 To UBound(mtrx(i))
If bb(d)(1, i) = mtrx(i)(j) Then ff = True: Exit For
Next
If Not ff Then
zz = mtrx(i): ReDim Preserve zz(1 To UBound(zz) + 1)
zz(UBound(zz)) = bb(d)(1, i): mtrx(i) = zz
If UBound(zz) > z Then z = UBound(zz)
End If
Next
End If
Next
ReDim Preserve mm(1 To UBound(aa, 2) - 1, 1 To UBound(mm, 2) + z)
For i = 1 To UBound(mtrx) 'здесь живут уники по главному (текущему) ключу
For j = 1 To UBound(mtrx(i)): mm(i, j + b - 2) = mtrx(i)(j): Next
Next
b = b + z
Next
ReDim dd(1 To b - 2, 1 To UBound(aa, 2) - 1)
For a = 1 To UBound(dd)
For c = 1 To UBound(dd, 2): dd(a, c) = mm(c, a): Next
Next
With .Cells(2, 11).Resize(b - 2, UBound(dd, 2))
.NumberFormat = "@": .Borders.LineStyle = 1: .Value = dd
End With
End With
Set DC = Nothing: Erase arr: Erase dd: Erase mm: Erase bb: Erase mtrx
End Sub
Anchoret написал: Словарь словарей есть. Теперь массив массивов
А теперь словарь массивов словарей
Скрытый текст
Код
Sub ArrayInDic()
Dim arr(), arrNew(), iDic()
Dim I&, J&, N&, iCount&
Dim mainKey, iKey
On Error Resume Next
With Worksheets("Лист1")
arr = .Range("A2:F" & .Cells(.Rows.Count, 1).End(xlUp).Row).Value
End With
ReDim iDic(2 To 6)
With CreateObject("Scripting.Dictionary")
For I = 1 To UBound(arr)
.Add arr(I, 1), Empty
If Err <> 0 Then
For J = 2 To UBound(arr, 2)
If Not IsEmpty(arr(I, J)) Then iTemp = .Item(arr(I, 1))(J)(arr(I, J))
Next
Err.Clear
Else
For J = 2 To UBound(arr, 2)
If Not IsEmpty(arr(I, J)) Then
Set iDic(J) = CreateObject("Scripting.Dictionary")
iTemp = iDic(J)(arr(I, J))
End If
Next
.Item(arr(I, 1)) = iDic
End If
Next
ReDim arrNew(1 To UBound(arr), 1 To 6): I = 1
For Each mainKey In .Keys
N = I: iCount = 0
arrNew(I, 1) = mainKey
For J = 2 To 6
iCount = IIf(iCount < .Item(mainKey)(J).Count, .Item(mainKey)(J).Count, iCount)
For Each iKey In .Item(mainKey)(J)
arrNew(N, J) = iKey: N = N + 1
Next
N = I
Next
I = I + iCount
Next
End With
Worksheets("Лист1").Range("O2").Resize(I, 6) = arrNew
End Sub
Не так элегантно как у Андрея (Андрей VG, ), но работает
Цитата
Mergens написал: никак не могу получить внутренние словари по ключу
Вот в этом блоке кода происходит именно это - получение массива словарей по главному ключу
Mergens написал: Я расширил процедуру Create, передаю массив и принимаю сформированный словарь
Зачем нарушать принципы ООП? В класс UniqueItem добавьте метод
Код
Friend Function GetColumnUniques(ByVal columnId As Long) As Variant
GetColumnUniques = FUniques(columnId).Keys
End Function
А в класс UniqueCollection
Код
' uniqueKey ключ уникального значения первого столбца, columnId номер ассоциированного тому ключу уникальных значений (начиная с 1, в примере значения от 1 до 5)
Public Function GetColumnUniques(ByVal uniqueKey As String, ByVal columnId As Long) As Variant
GetColumnUniques = FUniqueItems(uniqueKey).GetColumnUniques(columnId)
End Function
Тогда в методе CreateUniqueArray модуля UniqueTaskModule можно получить массив уникальных значений для данного 10010394
Код
Dim col3Uniques
col3Uniques = uCollection.GetColumnUniques("10010394", 3)
Option Explicit
Type my_dictionary
dic1 As Object
dic2 As Object
End Type
Sub test()
' ---------------------------------------------
Dim arr(), i&, j&, k&, txt$, ikey, s&, m&
Dim objDic As my_dictionary, sh As Worksheet
' ---------------------------------------------
Set objDic.dic1 = CreateObject("Scripting.Dictionary")
Set objDic.dic2 = CreateObject("Scripting.Dictionary")
Set sh = ActiveSheet
Application.ScreenUpdating = False
sh.Range("k:p").Clear
sh.Range("k:p").NumberFormat = "@"
arr = sh.[a1].CurrentRegion.Value
ReDim larr(1 To UBound(arr) - 1, 1 To UBound(arr, 2))
For i = 2 To UBound(arr)
txt = arr(i, 1)
objDic.dic1.Item(txt) = objDic.dic1.Item(txt) + 1
Next i
For Each ikey In objDic.dic1.Keys
j = 0
ReDim iarr(1 To objDic.dic1.Item(ikey), 1 To UBound(arr, 2))
For i = 1 To UBound(arr)
If ikey = arr(i, 1) Then
j = j + 1
For k = 2 To UBound(arr, 2)
iarr(j, k) = arr(i, k)
Next k
End If
Next i
For i = 2 To UBound(iarr, 2)
iarr(1, 1) = ikey
s = 0
For j = 1 To UBound(iarr)
txt = iarr(j, i)
If Not objDic.dic2.Exists(txt) Then
objDic.dic2.Item(txt) = 0
iarr(j, i) = Empty
s = s + 1
iarr(s, i) = txt
Else: iarr(j, i) = Empty
End If
Next j
objDic.dic2.RemoveAll
Next i
sh.[k1].Resize(, UBound(arr, 2)).Merge
m = sh.[k1].CurrentRegion.Rows.Count + 1
With sh.Cells(m, "k").Resize(UBound(iarr), UBound(iarr, 2))
.Value = iarr
.Borders.LineStyle = 1
End With
Next ikey
sh.Columns.AutoFit
Application.ScreenUpdating = True
End Sub
"Все гениальное просто, а все простое гениально!!!"
Mergens написал: Public Function GetColumnUniques(ByVal uniqueKey As String, ByVal columnId As Long) As Variant?
Не, коллега. Тут всё забавнее. Если дополнительные методы в классах описаны как выше, то применение col3Uniques = uCollection.GetColumnUniques("10010394", 3) действительно даёт ошибку, если метод GetColumnUniques в классе UniqueItem имеет атрибут доступа Friend. Видимо, когда доступ к этому методу идёт сразу через
это трактуется как позднее связывание (объект в словаре просто типа Object, а не UniqueItem) и, соответственно, метод GetColumnUniques в классе UniqueItem считается расположенным в другом пространстве, следовательно недоступен. Если поменять атрибут доступа на Public, то работает. Если оставить Friend, то нужно переписать метод GetColumnUniques класса UniqueCollection в такой вид
Код
Public Function GetColumnUniques(ByVal uniqueKey As String, ByVal columnId As Long) As Variant
Dim pItem As UniqueItem
Set pItem = FUniqueItems(uniqueKey)
GetColumnUniques = pItem.GetColumnUniques(columnId)
End Function
Mergens, приношу свои извинения, предложил код не протестировав.
Sanja, я Ваш код тестировал, и он хорош, но не соответствует моей просьбе. Мне надо было это все дело запихнуть в словарь, как раз именно это и сделал Андрей VG, плюсом открылась еще необходимость извлечения конкретных значений присвоенных по ключу из внутренних словарей. В приложенном файле, в целевой области, это то что должно лежать в словаре, просто по другому никак не расписать(((. Вся обработка происходит в памяти, и словарь словарей, это промежуточная стадия, потом начинается раскладка по ключу словарей из словаря и применение их к области для формирования для запуска функциональности. Есть такой старый продукт, SAP BexAnalyzer по сути оболочка работающая на Excel, вот там есть функциональность требующая создания областей планирования для запуска другой функциональности. вот для нее и пилю уже 2 недели гранит с 8 утра до 3х ночи.
А так Вам тоже Спасибо, и Спасибо Anchoret, я бы так не смог как Вы сообразить написать код(((( думалка видимо по проще((((