ВПР через разделитель

[Евгений Таб]

Добрый день.

Подскажите пож-ста инструмент (макрос) для ВПР через разделитель.
Пользовательская формула имеется для таких операций.

А когда значений более 600 тыс строк, то формула не подойдет.

Очень прошу помощи.

Во вложении пример. Зеленое дано, желтое нужно получить.

Спасибо.

ps было бы замечально чтобы код был без R1C1 ccылок и более менее понятный неопытному юзеру.

Заранее большое спасибо!

[kalbasiatka]

Хороший пример, цветастенький. А формула где? Или тут надо самому допетрить, как оно получилось?

[alex77755]

Макрос

Sub QWERT()
Dim R, M(), D, DR, W
    M = Range("A1").Resize(UsedRange.Rows.Count, 6).Value
    Set D = CreateObject("Scripting.Dictionary")
    For R = 2 To UBound(M)
        If D.Exists(M(R, 1)) Then
            D(M(R, 1))(M(R, 3)) = M(R, 3)
        Else
            Set DR = CreateObject("Scripting.Dictionary")
            DR(M(R, 3)) = M(R, 3)
            D.Add M(R, 1), DR
        End If
    Next R
    
    For R = 2 To UBound(M)
            For Each DR In D(M(R, 1)).keys
                M(R, 6) = IIf(Len(M(R, 6)) = 0, DR, M(R, 6) & "/" & DR)
            Next
    Next R
    Range("A1").Resize(UsedRange.Rows.Count, 6) = M
End Sub

[Евгений Таб]

alex77755, спасибо! + тебе

А как запускать это чудо не из листа, а из модуля?

[alex77755]

перенести процедуру в модуль поправив адресацию в 2 строках

 M = Range("A1").Resize(ActiveSheet.UsedRange.Rows.Count, 6).Value
 Range("A1").Resize(ActiveSheet.UsedRange.Rows.Count, 6) = M

И можно добавить строчку очистки колонки результата что бв не умножались результаты при повторном запуске

    For R = 2 To UBound(M)
            M(R, 6) = ""