Перейти к содержимому

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

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

  1. Отбор уникальных значений из списка
  2. Добавление уникальных элементов в ListBox
  3. Запись уникальных значений на рабочий лист

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

При написании макросов для работы с данными в 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. Отбор уникальных значений из списка: 9 комментариев

  1. Холмурод

    Можно ли сделать так :
    'при необходимости сортируем полученный список в столбце "A"
    Range(Cells(1, 2), Cells(i, 2)).Sort Key1:=Range("А51"), Order1:=xlAscending, _
    Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
    у меня не получается, помогите пожалуйста, заранее спасибо!
    С приветом Холмурод.

  2. Евгений

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

  3. Холмурод

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

    Option Explicit

    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

  4. Евгений

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

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

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

    Range(Cells(30, 1), Cells(i, 1))

  5. Холмурод

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

  6. Антон

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

  7. Евгений (автор статьи)

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

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

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

    On Error Resume Next
    
  8. Антон

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

  9. Евгений (автор статьи)

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

Добавить комментарий

Ваш комментарий будет опубликован после прохождения обязательной модерации. Исходящие ссылки не допускаются. Время модерации составит от нескольких минут до нескольких часов в зависимости от времени суток и занятости модератора.