Это можно сделать несколькими способами.
1) Наиболее простой и быстрый из них – создание сводной таблицы.
Поученный при этом столбец уникальных данных просто копируем в другое место.
2) Отсортировать данные по нужному столбцу, а затем запустить макрос выборки сведений
3) Использование свойства заполнения коллекции по уникальному ключу с последующей сортировкой.
Например, как в этом коде.
Sub Predmet()
‘Изменена под конкретный выбор
‘Выбор уникальных дисциплин из наименований дисциплин
‘Результат будет находиться в 3 колонке
‘Данные берутся из 1 колонки
Dim AllCells As Range, Cell As Range
Dim NoDupes As New Collection
Dim i As Integer
Dim j As Integer
Dim Swap1, Swap2, Item
‘Dim Tip1 As String
If ActiveSheet.Name <> “Лист1” Then
Sheets(“Лист1”).Activate
End If
Adres = “A1:A237”
‘ Элементы находятся в диапазоне Adres_Oblast
Set AllCells = Range(Adres)
On Error Resume Next
For Each Cell In AllCells
NoDupes.Add Cell.Value, CStr(Cell.Value)
Next Cell
On Error GoTo 0
MsgBox NoDupes.Count
For i = 1 To NoDupes.Count – 1
For j = i + 1 To NoDupes.Count
If NoDupes(i) > NoDupes(j) Then
Swap1 = NoDupes(i)
Swap2 = NoDupes(j)
NoDupes.Add Swap1, before:=j
NoDupes.Add Swap2, before:=i
NoDupes.Remove i + 1
NoDupes.Remove j + 1
End If
Next j
Next i
‘MsgBox NoDupes.Count – 1
‘ Добавление уникальных значений в объект ListBox
i = 1
For Each Item In NoDupes
Sheets(1).Cells(i, 3) = Item
i = i + 1
Next Item
End Sub
Обработку с применением коллекции удобно часто совмещать с добавлением выбранных уникальных данных в ListBox или ComboBox.
Применение ListBox позволяет организовать последующую выборку по группе выделенных значений.
Или другой пример с использованием подпрограммы и загрузкой выбранных данных в ListBox Userform2:
Sub RemoveDuplicates(Adres)
Dim AllCells As Range, Cell As Range
Dim NoDupes As New Collection
Dim i As Integer
Dim j As Integer
Dim Swap1, Swap2, Item
‘ Элементы находятся в диапазоне Adres_Oblast
Set AllCells = Range(Adres)
On Error Resume Next
For Each Cell In AllCells
NoDupes.Add Cell.Value, CStr(Cell.Value)
Next Cell
On Error GoTo 0
With UserForm2
.Label1.Caption = “Всего элемнтов: ” & AllCells.Count
.Label2.Caption = “Уникальных элементов: ” & NoDupes.Count
End With
‘Сортировка
For i = 1 To NoDupes.Count – 1
For j = i + 1 To NoDupes.Count
If NoDupes(i) > NoDupes(j) Then
Swap1 = NoDupes(i)
Swap2 = NoDupes(j)
NoDupes.Add Swap1, before:=j
NoDupes.Add Swap2, before:=i
NoDupes.Remove i + 1
NoDupes.Remove j + 1
End If
Next j
Next i
‘ Добавление уникальных значений в ListBox
For Each Item In NoDupes
UserForm2.ListBox1.AddItem Item
Next Item
‘ Отображение окна UserForm
UserForm2.Show
End Sub
Текст этой заметки в формате Word
Отбор уникальных записей через коллекцию реализован в примерах к главе 14