Макрос объединения ячеек по условию

[Vittel]

День добрый!
Получил задание :
Если № повторяется несколько раз, то разные адреса с данным номером прописываются в 1 ячейку через ;
К примеру как видим на скрине, номер 2609 повторяется 3 раза, значит макрос должен отработать так : 1 ячейка = 2609, а рядом с ней ячейка Каширское шоссе 78 к.2;Каширское шоссе 78 к.3;Каширское шоссе 78 к.4
И так на все 30000 строк, повторение № встречается до 40 раз.



Помогите пожалуйста 

[cheshiki1]

файл пример прицепите.

[Vittel]

Добавил файл с примером, всего строк около 31к

[cheshiki1]

Код Выделить Развернуть

Sub uuu()
Dim a(), LR#, i#, sd As Object
LR = Cells(Rows.Count, 1).End(xlUp).Row 'определяем последнюю заполненную ячейку по первому столбцу
a = Range("A3:B" & LR).Value 'заносим данные с листа в массив
Set sd = CreateObject("Scripting.Dictionary") ' объявляем словарь.
   For i = 1 To UBound(a) ' цикл по массиву
     If sd.Exists(a(i, 1)) Then ' если ключ в словаре есть то
       sd.Item(a(i, 1)) = sd.Item(a(i, 1)) & "; " & a(i, 2) ' к значению существующего ключа дописываем новое значение
     Else ' иначе
       sd.Item(a(i, 1)) = a(i, 2) ' создаем ключ с именем из первого столбца массива и значением из второго столбца массива
     End If
   Next
   Cells(3, 4).Resize(sd.Count) = Application.Transpose(sd.Keys) ' записываем имена ключей в 4 столбец
   Cells(3, 5).Resize(sd.Count) = Application.Transpose(sd.Items) ' записываем значения соответствующие ключам в 5 столбец
End Sub

хотя т.к. строк 31к то возможно в массив зря загнал, (опыта маловато). Попробуйте если что перепишу без массива.

[Vittel]

Спасибо, но этот код выводит только уникальный №, а вот адреса выводить не хочет, ругается.

[cheshiki1]

не хочет, ругается.

что пишет то. подозреваю что в вашем файле в 5 столбце есть что то мешающее вставке.
в примере соорудил 31тыщ. строк макрос сработал без проблем.