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