Здравствуйте, друзья! Снова нуждаюсь в помощи. Есть два столбца: ссылка и номер. Ссылки в столбце могут повторяться, при этом рядом с ними стоят разные номера. Нужно создать список уникальных ссылок, но сохранив все их номера. Кол-во строк - под миллион. Пытался сделать через массивы, но понял, что это дохлый номер. Судя по форумам, скорее всего нужен словарь, коим не владею. Прикрепил файл с примером, в котором два первых столбца - исходные данные, следующие два - то, что нужно получить на выходе. При этом, желательно, чтобы конечные данные тоже располагались в первых двух столбцах. Заголовок только для примера. Вообще его нет.
Заранее спасибо!
Здравствуйте, друзья! Снова нуждаюсь в помощи. Есть два столбца: ссылка и номер. Ссылки в столбце могут повторяться, при этом рядом с ними стоят разные номера. Нужно создать список уникальных ссылок, но сохранив все их номера. Кол-во строк - под миллион. Пытался сделать через массивы, но понял, что это дохлый номер. Судя по форумам, скорее всего нужен словарь, коим не владею. Прикрепил файл с примером, в котором два первых столбца - исходные данные, следующие два - то, что нужно получить на выходе. При этом, желательно, чтобы конечные данные тоже располагались в первых двух столбцах. Заголовок только для примера. Вообще его нет.
With ActiveSheet If .FilterMode Then .ShowAllData x = .Range("A1:B" & .Cells(Rows.Count, 1).End(xlUp).Row).Value End With
With CreateObject("Scripting.Dictionary") .CompareMode = 1 For i = 1 To UBound(x) If .Exists(x(i, 1)) Then rw = .Item(x(i, 1)) x(rw, 2) = x(rw, 2) & ";" & x(i, 2) Else k = k + 1: .Item(x(i, 1)) = k x(k, 1) = x(i, 1) x(k, 2) = x(i, 2) End If Next i End With
Range("A1:B" & Cells(Rows.Count, 1).End(xlUp).Row).ClearContents Range("A1:B1").Resize(k).Value = x End Sub
[/vba]
emkub, привет попробуйте:
[vba]
Код
Sub ertert() Dim x, i&, k&, rw&
With ActiveSheet If .FilterMode Then .ShowAllData x = .Range("A1:B" & .Cells(Rows.Count, 1).End(xlUp).Row).Value End With
With CreateObject("Scripting.Dictionary") .CompareMode = 1 For i = 1 To UBound(x) If .Exists(x(i, 1)) Then rw = .Item(x(i, 1)) x(rw, 2) = x(rw, 2) & ";" & x(i, 2) Else k = k + 1: .Item(x(i, 1)) = k x(k, 1) = x(i, 1) x(k, 2) = x(i, 2) End If Next i End With
Range("A1:B" & Cells(Rows.Count, 1).End(xlUp).Row).ClearContents Range("A1:B1").Resize(k).Value = x End Sub
Это великолепно! Почти миллион строк обработало приблизительно за минуту. Обычное сравнение в массиве, даже с пошаговым уменьшением - более часа (потом мне надоело ждать и убил процесс). В вашем макросе не все строки понимаю. Можете закомментировать основные шаги, если не сложно? СПАСИБО!
Это великолепно! Почти миллион строк обработало приблизительно за минуту. Обычное сравнение в массиве, даже с пошаговым уменьшением - более часа (потом мне надоело ждать и убил процесс). В вашем макросе не все строки понимаю. Можете закомментировать основные шаги, если не сложно? СПАСИБО!emkub
Вход
Регистрация
Напомнить пароль
Автосумма
Часто используемые
ВПР
ЕСЛИ
СУММЕСЛИ
Финансовые
Логические
Текстовые
Даты и времени 
Ссылки и массивы 
Математические
Другие функции
Проверка свойств и значений
Баз данных
Математические
Обработки массивов
Обработки строк
Преобразования типов данных 
Загрузки данных
Работы с файлами
Обработки системных параметров
Обработки цвета
Работы с датами и временем
Преобразования в системы счисления
Финансовые
