VBA Excel. Отбор уникальных значений с помощью Collection

Отбор уникальных значений из списка в VBA Excel с помощью объекта Collection. Выгрузка уникальных элементов в ListBox и ячейки рабочего листа. Скачать файл с примером кода.

Содержание

Отбор уникальных значений из списка

При написании макросов для работы с данными в VBA Excel иногда возникает необходимость отбора уникальных значений из списка с повторяющимися элементами. Для этого можно воспользоваться следующим кодом:

Sub ОтборУникальных()

'Объявляем переменные

'myRange - диапазон ячеек, заполненный исходным списком элементов

'myCell - отдельная ячейка диапазона

'myCollection - коллекция

'myElement - элемент коллекции (должен быть типа "Variant")

Dim myRange As Range, myCell As Range, myCollection As New Collection, _

myElement As Variant, i As Long

'присваиваем переменной myRange диапазон ячеек с исходным списком элементов

Set myRange = Range("A1:A20")

'заполняем новую коллекцию уникальными элементами

On Error Resume Next

For Each myCell In myRange

myCollection.Add CStr(myCell.Value), CStr(myCell.Value)

Next myCell

On Error GoTo 0

На этом отбор уникальных значений завершен. Коллекция заполнена уникальными элементами.

Добавление уникальных элементов в ListBox

Теперь можно добавить уникальные значения в ListBox, если перед этим создать форму UserForm1 и на нее добавить элемент управления ListBox1:

For Each myElement In myCollection

UserForm1.ListBox1.AddItem myElement

Next myElement

ListBox заполнен уникальными значениями из коллекции. Другие способы заполнения ListBox и ComboBox смотрите здесь.

Запись уникальных значений на рабочий лист

А так можно добавить уникальные элементы в ячейки столбца «В» активного рабочего листа:

For Each myElement In myCollection

i = i + 1

Cells(i, 2) = myElement

Next myElement

При необходимости сортируем полученный список в столбце "В":

Range(Cells(1, 2), Cells(i, 2)).Sort Key1:=Range("B1"), Order1:=xlAscending, _

Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom

А также можно отобразить количество найденных уникальных элементов, если, конечно, на форму UserForm1 добавлен элемент управления Label1:

UserForm1.Label1.Caption = "Уникальных элементов: " & myCollection.Count

'отображаем форму

UserForm1.Show

End Sub

Если вам необходимо в ListBox или ComboBox загрузить отсортированный список, его элементы можно добавить с листа Excel после сортировки, в данном примере из диапазона Range(Cells(1, 2), Cells(i, 2)).

Обратите внимание, что в представленном коде VBA Excel для отбора уникальных значений из списка, выгрузки их в ListBox и записи на рабочий лист идет сплошная нумерация от Sub ОтборУникальных() и до End Sub.

Для наглядного ознакомления с работой представленного кода вы можете скачать демонстрационный файл.

Смотрите, как удалить повторяющиеся значения из диапазона ячеек в VBA Excel с помощью метода Range.RemoveDuplicates и отобрать уникальные значения из списка с помощью объекта Dictionary.

Содержание рубрики VBA Excel по тематическим разделам со ссылками на все статьи.

32 комментария для “VBA Excel. Отбор уникальных значений с помощью Collection”

Холмурод 12.08.2018 в 20:54

Можно ли сделать так :

'при необходимости сортируем полученный список в столбце "A"

Range(Cells(1, 2), Cells(i, 2)).Sort Key1:=Range("А51"), Order1:=xlAscending, _

Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom

у меня не получается, помогите пожалуйста, заранее спасибо!
С приветом Холмурод.

Евгений 12.08.2018 в 22:53

Привет, Холмурод. В примере указан диапазон из столбца «B»: Range(Cells(1, 2), Cells(i, 2)). Замените его на диапазон из столбца «A»: Range(Cells(1, 1), Cells(i, 1)).

Холмурод 13.08.2018 в 03:53

Привет Евгений.
в ListBox1 список покажет но Sort Key1:=Range(«A30») в ячейке A30 ничего нет. Сделал вот так:

Sub ОтборУникальных()

'Объявляем переменные

'myRange - диапазон ячеек, заполненный исходным списком элементов

'myCell - отдельная ячейка диапазона

'myCollection - коллекция

'myElement - элемент коллекции (должен быть типа "Variant")

Dim myRange As Range, myCell As Range, myCollection As New Collection, _

myElement As Variant, i As Long

'присваиваем переменной myRange диапазон ячеек с исходным списком элементов

Set myRange = Range("A1:A20")

'заполняем новую коллекцию уникальными элементами

On Error Resume Next

For Each myCell In myRange

myCollection.Add CStr(myCell.Value), CStr(myCell.Value)

Next myCell

On Error GoTo 0

'на этом отбор уникальных значений закончен

'теперь можно добавить уникальные элементы в ListBox

For Each myElement In myCollection

UserForm1.ListBox1.AddItem myElement

Next myElement

'так можно добавить уникальные элементы в ячейки столбца "A" активного листа

For Each myElement In myCollection

i = i + 1

Cells(i, 1) = myElement

Next myElement

'при необходимости сортируем полученный список в столбце "A"

Range(Cells(1, 1), Cells(i, 1)).Sort Key1:=Range("A30"), Order1:=xlAscending, Header:=xlGuess, _

OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom

'а также можно отобразить количество найденных уникальных элементов

UserForm1.Label1.Caption = _

"Уникальных элементов: " & myCollection.Count

'отображаем форму

UserForm1.Show

End Sub

Евгений 13.08.2018 в 10:31

Холмурод, а вы хотите сделать, чтобы вставленный на лист список начинался с ячейки A30? Если да, то тогда выгрузку на лист надо начать с 30-й ячейки:

1
2
3
4

For Each myElement In myCollection
i = i + 30
Cells(i, 1) = myElement
Next myElement

и для сортировки указать диапазон, начинающийся с 30-й ячейки:

1

Range(Cells(30, 1), Cells(i, 1))
Холмурод 15.08.2018 в 23:03

Евгений огромное Вам спасибо!!!
просто получилось.
Антон 29.11.2018 в 19:08

Добрый день,
В приведенном примере создаётся коллекция уникальных значений. Все работает. Только я не пойму чем, в какой строке определяется уникальность значений этих значений? Где происходит сравнение ? Ведь, наверное, в коллекцию должны записаться все элементы из Range(«A1:A20») ?
Евгений 29.11.2018 в 19:39

Привет, Антон.
Уникальность значений проверяется в строке добавления очередного элемента в коллекцию:

1

myCollection.Add CStr(myCell.Value), CStr(myCell.Value)

Первое выражение CStr(myCell.Value) определяет записываемый элемент в коллекцию, второе определяет добавляемый ключ. Ключ в коллекции не может быть неуникальным, поэтому если он уже есть в коллекции, генерируется ошибка, и цикл переходит к обработке следующей ячейки. Чтобы программа не останавливалась при возникновении ошибок, перед циклом добавлена строка:

1

On Error Resume Next
1. Дмитрий 07.07.2019 в 10:52
  
  Простое и элегантное решение поиска уникальных значений!
  Спасибо!
2. Камалджан 18.05.2020 в 10:37
  
  Добрый день!
  Странно у меня не срабатывает данный код и выдает ошибку «This key already associated with element of this collection»
3. Евгений 18.05.2020 в 11:08
  
  Привет, Камалджан!
  Строка
  
  1
  
  On Error Resume Next
  
  должна стоять перед строкой
  
  1
  
  myCollection.Add CStr(myCell.Value), CStr(myCell.Value)
  
  чтобы пропускать ошибки “This key already associated with element of this collection”, как в исходном коде из этой статьи:
  
  1
  2
  3
  4
  5
  
  On Error Resume Next
  For Each myCell In myRange
  myCollection.Add CStr(myCell.Value), CStr(myCell.Value)
  Next myCell
  On Error GoTo 0
Антон 30.11.2018 в 15:56

Евгений,
Снимаю шляпу…..
Тонко придумано.
Спасибо
Евгений 30.11.2018 в 16:54

Антон, это решение я подсмотрел у Джона Уокенбаха в книге «Excel 2010: профессиональное программирование на VBA».
Фарин 01.03.2019 в 21:21

Евгений, хорошо было бы привести пример со словарем в дополнение к коллекции.
И рассказать как-нибудь про метод Range.RemoveDuplicates
Евгений 05.03.2019 в 13:40

Привет, Фарин!
Согласен с вашими пожеланиями, принял их к сведению.
Андрей 19.11.2020 в 11:00

Добрый день!
Скажите пожалуйста, чувствителен ли данный метод добавления уникальных значений к регистру?
Я делаю выборку уникальных значений по полю, и значения «Сибирь» и «сибирь» почему то присваиваются одному значению «сибирь».
Может быть чувствительность как то отключается/включается?
Подскажите пожалуйста )
1. Евгений 19.11.2020 в 12:55
  
  Добрый день, Андрей!
  Ключи объекта Collection нечувствительны к регистру. Если вы хотите отобрать уникальные значения с учетом регистра, используйте код с объектом Dictionary.
Андрей 20.11.2020 в 04:05

Евгений, спасибо большое за ответ! Принял к использованию )
Вольдемар 18.12.2020 в 19:04

Здравствуйте, очень интересный метод, но это работает только на простом списке? то есть, можно ли применить этот метод для таблицы из 2-3 столбцов с проверкой на уникальность только по одному столбцу?

Евгений 18.12.2020 в 21:11

Здравствуйте, Вольдемар!
Можно удалить из таблицы строки с неуникальными значениями в одном столбце, проверяя уникальность значений снизу вверх:

Private Sub CommandButton1_Click()

Dim myCollection As New Collection, i As Long, n As Long, m As Long

n = 20 'Количество строк в таблице

m = 1 'Номер столбца

For i = n To 1 Step -1

On Error Resume Next

myCollection.Add CStr(Cells(i, m).Value), CStr(Cells(i, m).Value)

If Err.Description <> "" Then

Rows(i).Delete

End If

On Error GoTo 0

End Sub

1. Вольдемар 19.12.2020 в 17:28
  
  мда, это ж надо так догадаться, спасибо, Евгений, я бы сам не додумался

Вадим 16.03.2021 в 07:12

Добрый день, а как сделать так, чтобы уникальные ячейки загружались на лист в определенный столбец?
1. Евгений 16.03.2021 в 17:16
  Привет, Вадим!
  
  1
  2
  3
  4
  5
  
  i = 10 - 1
  For Each myElement In myCollection
  i = i + 1
  Worksheets("Лист1").Cells(i, "D") = myElement
  Next myElement
  
  В выражении i = 10 - 1 число 10 указывает, что заполнение столбца начнется с 10 строки. Если заполнение должно начаться с первой ячейки заданного столбца, это выражение следует исключить из процедуры.
  
  В выражении Worksheets("Лист1").Cells(i, "D") = myElement:
  
  "Лист1" – наименование ярлыка листа, в ячейки которого будут вставляться уникальные значения;
  
  "D" – буквенное обозначение столбца, который будет заполняться (можно заменить на числовое значение: 1 вместо «A», 2 вместо «B» и т.д.).
Ирина 22.09.2021 в 20:01

Здравствуйте, помогите пожалуйста нужен код для получения уникального списка по критерию в соседнем столбце
Дитрий 01.02.2022 в 17:11

Добрый день. Помогите пож. «Играюсь» с Collection. При попытке вывести кол-во членов коллекции через Collection.Count Программа выдает кол-во строк указанного диапазона(( , а не кол-во знаков в диапазоне. И только повтором типа myCollection.Add CStr(myCell.Value), CStr(myCell.Value) MsgBox выдает кол-во членов коллекции корректно. Почему??((

Евгений 01.02.2022 в 19:20

Здравствуйте, Дитрий!
Пример кода, пожалуйста.

Дитрий 02.02.2022 в 10:32

Евгений, добрый день! Только начинаю изучать VBA. Вопросов!!! Постараюсь в будущем по пустякам не отвлекать).
По существу дела:

Sub A18()

Dim MyColl As New Collection, myRange As Range, c As Range

Set myRang = Range("A1:A20") ' в столбе буквы и цифры

On Error Resume Next

For Each c In myRang

MyColl.Add CStr(c.Value), CStr(c.Value) 'только повторение CStr(c.Value) дает нужные данные

On Error GoTo 0

MsgBox MyColl.Count

End Sub

Хочется узнать:
1. Почему только повторение CStr(c.Value) дает кол-во уникальных знаков, в противном случае дает значение 20 (я почему жду в результате кол-во всех знаков, но без учета пустых ячеек);
2. К моему удивлению макрос выдает данные только с типом возвращ. значений CStr;
3. И если не сложно подсказать куда двигаться: Возможно ли в коллекцию отбирать уже данные с нужными параметрами или для этого нужно использовать другие инструменты?
За ранее, огромное спс.!!!

1. Евгений 02.02.2022 в 13:17
  
  Добрый день, Дитрий!
  
  1. Первое выражение CStr(c.Value) определяет записываемый элемент в коллекцию, второе определяет добавляемый ключ. Ключ в коллекции не может быть неуникальным, поэтому если он уже есть в коллекции, генерируется ошибка, и цикл переходит к обработке следующей ячейки. Чтобы программа не останавливалась при возникновении ошибок, перед циклом добавлена строка: On Error Resume Next.
  
  2. Элементы коллекции могут содержать разные типы данных, если их не преобразовывать в текст: MyColl.Add c.Value.
  
  3. Я использую коллекции только для отбора уникальных значений, в остальных случаях — массивы. Копирование значений из диапазона ячеек в массив и обратно.
2. 1. Дитрий 02.02.2022 в 14:24
    
    Евгений, от души! Все ясно, я получил исчерпывающий ответ.
    P.S. Спасибо за Вашу работу! Этот один из лучших обучающих ресурсов!!!

Елена 07.06.2022 в 18:04

Добрый день! Подскажите, пожалуйста, как можно реализовать следующую задачу. В столбце А есть набор значений, некоторые из которых повторяются, в столбце B набор соответствующие им уникальные значения. В столбец C нужно вывести 1) если значение в столбце А уникальное — то значение из столбца B 2) если значение не уникальное — среднее арифметическое по всем соответствующим этому значению из столбца B.
Спасибо заранее!
Пётр 25.11.2022 в 23:04

Добрый день!

Всё понятно по коду, работает, спасибо большое!
Вопрос: что делает «On Error GoTo 0»?
Погуглил: «Отключает любой включенный обработчик ошибок в текущей процедуре.» Ни о чём не говорит) Подскажите на пальцах, пожалуйста. В связи с чем возник вопрос: если удалить эту строку, то ничего не происходит, код работает как и работал.
В чём смысл строки? Заранее благодарю за ответ!
1. Евгений 25.11.2022 в 23:33
  
  Здравствуйте, Пётр!
  Выражение «On Error Resume Next» включает обработчик ошибок, который при возникновении ошибки игнорирует ее и передает управление следующей строке. Если не добавить «On Error GoTo 0», то ошибки, которые могут возникнуть при выполнении нижележащих строк кода, также будут проигнорированы.
2. 1. Пётр 26.11.2022 в 12:08
    
    Спасибо большое! Просто и ясно!

Обсуждение закрыто.