Профессиональные приемы работы в Microsoft Excel

Обмен опытом => Microsoft Excel => Тема начата: Vittel от 01.07.2015, 12:02

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

(http://s015.radikal.ru/i330/1507/69/0e2c613ad507.jpg) (http://www.radikal.ru)

Помогите пожалуйста  :)
Название: Re: Макрос объединения ячеек по условию
Отправлено: cheshiki1 от 01.07.2015, 15:12
файл пример прицепите.
Название: Re: Макрос объединения ячеек по условию
Отправлено: Vittel от 01.07.2015, 15:14
Добавил файл с примером, всего строк около 31к
Название: Re: Макрос объединения ячеек по условию
Отправлено: cheshiki1 от 01.07.2015, 15:47
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к то возможно в массив зря загнал, (опыта маловато). Попробуйте если что перепишу без массива.
Название: Re: Макрос объединения ячеек по условию
Отправлено: Vittel от 02.07.2015, 10:26
Спасибо, но этот код выводит только уникальный №, а вот адреса выводить не хочет, ругается.
(http://s017.radikal.ru/i430/1507/f6/0486bd82f517.jpg) (http://www.radikal.ru)
Название: Re: Макрос объединения ячеек по условию
Отправлено: cheshiki1 от 02.07.2015, 15:18
Цитата: Vittel от 02.07.2015, 10:26
не хочет, ругается.
что пишет то. подозреваю что в вашем файле в 5 столбце есть что то мешающее вставке.
в примере соорудил 31тыщ. строк макрос сработал без проблем.