Добрый день, уважаемые форумчане! Что есть: таблица объектов с уникальными идентификаторами, таблица событий, случившихся с этими объектами. События объединены в группы. Общее число групп известно - их около 40. С каждым объектом могут происходить события как из одной группы, так и из разных, а могут не происходить вовсе. Таблицы разнесены по разным листам. Передо мной стоит задача: в таблице объектов в одной ячейке перечислить ВСЕ группы событий, случившихся с ним. При этом если с одним объектом случаются несколько событий одной группы, то группа должна указываться только один раз. Перечень групп в этой ячейке должен быть разделен переводом строки (Alt-Enter). Я пробовал использовать множественный ВПР из Приемов на этом сайте и функции из Plex, но качественного результата не получил. В частности, если у объекта только одно событие (естественно, только одна группа), то значение не подгрузилось. Используется Excel16. Пример, сделанный вручную, "как хочется, чтобы было", приложен. Очень надеюсь на помощь гуру. Заранее благодарю.
Sub ОбъектыГруппы()
Dim r1 As Range
Dim y As Long
With Sheets("Объекты")
y = .Cells(.Rows.Count, "B").End(xlUp).Row
If y = 1 Then Exit Sub
Set r1 = .Range(.Cells(1, "B"), .Cells(y, "B"))
End With
Dim arr As Variant
With Sheets("События")
y = .Cells(.Rows.Count, "B").End(xlUp).Row
If y = 1 Then Exit Sub
arr = .Range(.Cells(1, "B"), .Cells(y, "C"))
End With
Dim dic As Object
Set dic = CreateObject("Scripting.Dictionary")
For y = 2 To UBound(arr, 1)
If Not IsEmpty(arr(y, 1)) Then
If Not dic.Exists(arr(y, 1)) Then Set dic.Item(arr(y, 1)) = CreateObject("Scripting.Dictionary")
End If
dic.Item(arr(y, 1)).Item(arr(y, 2)) = 0
Next
Erase arr
arr = r1
Dim brr As Variant
ReDim brr(1 To UBound(arr, 1), 1 To 1)
brr(1, 1) = r1.Cells(1, 2)
For y = 2 To UBound(arr, 1)
If dic.Exists(arr(y, 1)) Then
brr(y, 1) = Join(dic.Item(arr(y, 1)).Keys(), vbCrLf)
End If
Next
r1.Cells(1, 2).Resize(UBound(arr, 1)) = brr
End Sub
Mershik, ВПР я использовал на реальном файле. Сейчас из дома сделал "модель" (что есть и что нужно) и обращаюсь за помощью. Я делал во вспомогательных столбцах, вытаскивая из таблицы событий группы, а потом пытался их сцеплять. Выбрать уникальные не удалось от слова "совсем", а вот с вытаскиванием групп в случае единичных вхождений - с этим я столкнулся: в таблице событий есть, а в объекты не попала.
МатросНаЗебре, макрос сработал на файле-приеме, спасибо. Правда, не уверен, что на рабочем файле разрешат запускать макросы, но попробую завтра. Можно попросить комментарии к коду, чтобы адаптировать его к реальности?
Уважаемые форумчане! Возобновляю тему, потому что задача, заявленная в начальном посте, становится регулярной. Но, к сожалению, не получается адаптировать макрос на листах с похожими данными, но на которых идентификаторы объектов и группы событий находятся в иных столбцах. В этой связи прошу "допилить" макрос, учитывая: 1. искать группы нужно по идентификаторам, а не названиям объектов, потому что идентификаторы уникальны, а названия объектов могут совпадать. 2. предоставить пользователю возможность через inputbox указывать столбцы (или начальные ячейки диапазонов), в которых находятся идентификаторы на листе объектов и группы на листе событий. Спасибо всем, кто откликнется!
Sub ОбъектыГруппы()
Application.EnableEvents = False
Application.ScreenUpdating = False
Dim r1 As Range
Dim y As Long
Dim ActiveCell_Row As Long
Dim ActiveCell_Column As Integer
Dim ActiveSheet_Name As String
ActiveSheet_Name = ActiveSheet.Name
With Sheets("Объекты")
.Select
If ActiveCell.Value = "Идент" Then
ActiveCell_Row = ActiveCell.Row
ActiveCell_Column = ActiveCell.Column
Else
MsgBox "Выделите ячейку идентификатора", vbInformation
Exit Sub
End If
y = .Cells(.Rows.Count, ActiveCell_Column).End(xlUp).Row
If y = ActiveCell_Row Then Exit Sub
Set r1 = .Range(.Cells(ActiveCell_Row, ActiveCell_Column), .Cells(y, ActiveCell_Column))
End With
Dim arr As Variant
With Sheets("События")
.Select
If ActiveCell.Value = "Идент" Then
ActiveCell_Row = ActiveCell.Row
ActiveCell_Column = ActiveCell.Column
Else
MsgBox "Выделите ячейку идентификатора", vbInformation
Exit Sub
End If
y = .Cells(.Rows.Count, ActiveCell_Column).End(xlUp).Row
If y = ActiveCell_Row Then Exit Sub
arr = .Range(.Cells(ActiveCell_Row, ActiveCell_Column), .Cells(y, ActiveCell_Column + 2))
End With
Dim dic As Object
Set dic = CreateObject("Scripting.Dictionary")
For y = 2 To UBound(arr, 1)
If Not IsEmpty(arr(y, 1)) Then
If Not dic.Exists(arr(y, 1)) Then Set dic.Item(arr(y, 1)) = CreateObject("Scripting.Dictionary")
End If
dic.Item(arr(y, 1)).Item(arr(y, 3)) = 0
Next
Erase arr
arr = r1
Dim brr As Variant
ReDim brr(1 To UBound(arr, 1), 1 To 1)
brr(1, 1) = r1.Cells(1, 3)
For y = 2 To UBound(arr, 1)
If dic.Exists(arr(y, 1)) Then
brr(y, 1) = Join(dic.Item(arr(y, 1)).Keys(), vbCrLf)
End If
Next
r1.Cells(1, 3).Resize(UBound(arr, 1)) = brr
Sheets(ActiveSheet_Name).Select
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
1. Переделан поиск групп по идентификаторам. 2. Начальные ячейки диапазонов задаются пользователем. Нужно на листах Объекты и События выделить ячейки со значением "Идент".