Страницы: 1
RSS
Создать уникальный список с подставлением значений в одну строку
 
Нужно создать уникальный список из таблицы с повторяющимися строками,  подставив рядом все значения в одну строку, НО объединенные по другому  столбцу. (см. файл-пример).

Приветствуется любое решение, через промежуточные таблицы, макросом или ещё как.
Я знаю лишь некоторые формулы, но и с ВПР, и с ИНДЕКС/ПОИСКПОЗ пока не вышло победить, уже голову сломал..  
 
https://www.planetaexcel.ru/forum/index.php?PAGE_NAME=read&FID=1&TID=89086
 
вариант макросом
 
Код
Sub Uniqtabl()
Dim arrData(), CollNumber As New Collection, CollTrac As New Collection
Dim i&, x&, c&, lRow&
arrData = wsData.Range("A1").CurrentRegion.Value
On Error Resume Next
For x = 2 To UBound(arrData, 1)
    CollNumber.Add arrData(x, 4), CStr(arrData(x, 4))
Next x
lRow = 5
With wsRezul
    .Range("A" & lRow).CurrentRegion.ClearContents
    For i = 1 To CollNumber.Count
        For x = 2 To UBound(arrData, 1)
            If arrData(x, 4) = CollNumber(i) Then
                CollTrac.Add arrData(x, 1), CStr(arrData(x, 1))
            End If
        Next x
        .Range("A" & lRow) = CollNumber(i)
        For x = 1 To CollTrac.Count
            .Range("B" & lRow) = .Range("B" & lRow) & CollTrac(x) & ": "
            For c = 2 To UBound(arrData, 1)
                If CollNumber(i) = arrData(c, 4) And CollTrac(x) = arrData(c, 1) Then
                    .Range("B" & lRow) = .Range("B" & lRow) & arrData(c, 2) & ", "
                End If
            Next c
            .Range("B" & lRow) = Left(.Range("B" & lRow), Len(.Range("B" & lRow)) - 2) & "; "
        Next x
        .Range("B" & lRow) = Left(.Range("B" & lRow), Len(.Range("B" & lRow)) - 2)
        lRow = lRow + 1
        Set CollTrac = Nothing
    Next i
End With
End Sub
Добавлен разделитель между Trac - "; "
 
Kuzmich,  спасибо за направление.

Dmitriy XM,  спасибо, интересное решение. Работает как надо.
Страницы: 1
Наверх