Страницы: 1
RSS
Объединить значения, относящиеся к одному названию, в одну ячейку
 
Уважаемые форумчани. Подскажите пожалуйста:
Есть таблица
Пример
А1=Петя
А2=Ваня
А3=Маша
А4=Петя
A5=Маша
B1=3 арбуза
B2=2 яблока
B3=1 корова
B4=2 апельсина
B5=4 конфеты

Сделать такого вида:
А1=Петя
А2=Ваня
А3=Маша

B1=3 арбуза (переход на след. строку) 2 апельсина
B2=2 яблока
B3=1 корова  (переход на след. строку) 4 конфеты

То-есть надо сделать уникальным столбец А и соответствующие ему значения B поместить в столбик в ячейках

Пример прикрепляю
Изменено: BobbyJo - 09.04.2018 10:58:34
 
См. вариант.
 
Макрос
Код
Sub BobbyJo()
Dim arr(), arrNew(), I&, iKey
With ActiveSheet
    arr = .Range("A2:B" & .Cells(.Rows.Count, "A").End(xlUp).Row).Value
End With
On Error Resume Next
With CreateObject("Scripting.Dictionary")
    For I = 1 To UBound(arr)
        .Add CStr(arr(I, 1)), arr(I, 2)
        If Err <> 0 Then
            .Item(CStr(arr(I, 1))) = .Item(CStr(arr(I, 1))) & vbCrLf & arr(I, 2)
            Err.Clear
        End If
    Next
    ReDim arrNew(0 To .Count, 0 To 1): I = 0
    For Each iKey In .Keys
        arrNew(I, 0) = iKey
        arrNew(I, 1) = .Item(iKey)
        I = I + 1
    Next
End With
ActiveSheet.Range("G2").Resize(I, 2) = arrNew
End Sub
Согласие есть продукт при полном непротивлении сторон
 
Power Query.
 
вариант
Код
Sub dc()
Dim dic
Set dic = CreateObject("Scripting.Dictionary")
For i = 2 To Cells(Rows.Count, 1).End(xlUp).row
    key = Cells(i, 1).Value
    item = Cells(i, 2).Value
    If dic.exists(key) Then
        dic.item(key) = dic.item(key) & Chr(10) & item
    Else
        dic.Add key, item
    End If
    Next
Cells(2, 6).Resize(dic.Count) = Application.Transpose(dic.Keys)
Cells(2, 7).Resize(dic.Count) = Application.Transpose(dic.Items)
End Sub
 
На любой вкус! :)
 
Спасибо!
 
Всем огромное спасибо! :)
Страницы: 1
Наверх