Страницы: 1
RSS
Собрать уникальные значения в одну ячейку макросом
 
Добрый день, уважаемые форумчане!
Что есть: таблица объектов с уникальными идентификаторами, таблица событий, случившихся с этими объектами. События объединены в группы. Общее число групп известно - их около 40. С каждым объектом могут происходить события как из одной группы, так и из разных, а могут не происходить вовсе. Таблицы разнесены по разным листам.
Передо мной стоит задача: в таблице объектов в одной ячейке перечислить ВСЕ группы событий, случившихся с ним. При этом если с одним объектом случаются несколько событий одной группы, то группа должна указываться только один раз. Перечень групп в этой ячейке должен быть разделен переводом строки (Alt-Enter).
Я пробовал использовать множественный ВПР из Приемов на этом сайте и функции из Plex, но качественного результата не получил. В частности, если у объекта только одно событие (естественно, только одна группа), то значение не подгрузилось.
Используется Excel16.
Пример, сделанный вручную, "как хочется, чтобы было", приложен.
Очень надеюсь на помощь гуру. Заранее благодарю.
Изменено: vikttur - 06.07.2021 12:52:49
 
kalle, а где у Вас ВПР?  и в одной ячейке можно только макросом https://www.planetaexcel.ru/techniques/7/205/
Изменено: Mershik - 03.06.2021 17:37:54
Не бойтесь совершенства. Вам его не достичь.
 
Код
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, ВПР я использовал на реальном файле. Сейчас из дома сделал "модель" (что есть и что нужно) и обращаюсь за помощью.
Я делал во вспомогательных столбцах, вытаскивая из таблицы событий группы, а потом пытался их сцеплять. Выбрать уникальные не удалось от слова "совсем", а вот с вытаскиванием групп в случае единичных вхождений - с этим я столкнулся: в таблице событий есть, а в объекты не попала.
 
МатросНаЗебре, макрос сработал на файле-приеме, спасибо. Правда, не уверен, что на рабочем файле разрешат запускать макросы, но попробую завтра.
Можно попросить комментарии к коду, чтобы адаптировать его к реальности?

А формулами никак не получится?
 
Цитата
kalle:  А формулами никак не получится?
Если офис 365:
=ОБЪЕДИНИТЬ("
";1;ФИЛЬТР(События!C$1:C$19;События!B$1:B$19=B2;""))
Изменено: Бахтиёр - 03.06.2021 18:36:01
 
Цитата
kalle написал:
чтобы адаптировать его к реальности
Если пример сзделан в реальной структуре, о чём написано в правилах, то никакой адаптации не потребуется.
 
Уважаемые форумчане!
Возобновляю тему, потому что задача, заявленная в начальном посте, становится регулярной. Но, к сожалению, не получается адаптировать макрос на листах с похожими данными, но на которых идентификаторы объектов и группы событий находятся в иных столбцах.
В этой связи прошу "допилить" макрос, учитывая:
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. Начальные ячейки диапазонов задаются пользователем. Нужно на листах Объекты и События выделить ячейки со значением "Идент".
 
Спасибо, буду разбираться ;)
 
Цитата
МатросНаЗебре написал:
Начальные ячейки диапазонов задаются пользователем
В рабочем файле данные собираются в 13 столбец ("М"). Я не могу понять, где нужно изменить адрес столбца-назначения.
Страницы: 1
Наверх