Как получить список уникальных значений из диапазона в Excel VBA?

Question

Я хотел бы получить список уникальных значений в диапазоне, используя VBA. Большинство примеров в Google говорят о получении списка уникальных значений в столбце с использованием VBA.

Я не уверен, как изменить его, чтобы получить список значений в диапазоне.

Например,

Currency Name 1 Name 2 Name 3 Name 4 Name 5 
SGD BGN DBS   
PHP PDSS     
KRW BGN    
CNY CBBT BGN   
IDA INPC     

Мой массив должен выглядеть следующим образом:

BGN, DBS, PDSS, CBBT and INPC. 

Как мне это сделать? Нужно руководствоваться.

Answer 1

Прокрутите круг, проверьте, находится ли значение в массиве, если не добавить его в массив.

Sub test() 
Dim Values() As Variant 
Values = GetUniqueVals(Selection) 
Dim i As Integer 
    For i = LBound(Values) To UBound(Values) 
     Debug.Print (Values(i)) 
    Next 

End Sub 

Function GetUniqueVals(ByRef Data As Range) As Variant() 
    Dim cell As Range 
    Dim uniqueValues() As Variant 
    ReDim uniqueValues(0) 

    For Each cell In Data 
     If Not IsEmpty(cell) Then 
      If Not InArray(uniqueValues, cell.Value) Then 
       If IsEmpty(uniqueValues(LBound(uniqueValues))) Then 
        uniqueValues(LBound(uniqueValues)) = cell.Value 
       Else 
        ReDim Preserve uniqueValues(UBound(uniqueValues) + 1) 
        uniqueValues(UBound(uniqueValues)) = cell.Value 
       End If 
      End If 
     End If 
    Next 
    GetUniqueVals = uniqueValues 
End Function 

Function InArray(ByRef SearchWithin() As Variant, ByVal SearchFor As Variant) As Boolean 
    Dim i As Integer 
    Dim matched As Boolean 'Default value of boolean is false, we make true only if we find a match 

    For i = LBound(SearchWithin) To UBound(SearchWithin) 
     If SearchWithin(i) = SearchFor Then matched = True 
    Next 

    InArray = matched 
End Function 

Answer 2

Я бы использовал простой VBA-Collection и добавил элементы с ключом. Ключом будет сам элемент, и поскольку не может быть дублированных ключей, коллекция будет содержать уникальные значения.

Примечание. Поскольку добавление дублированного ключа в коллекцию вызывает ошибку, завершите вызов коллекции-add в on-error-resume-next.

Функция GetUniqueValues имеет источник-диапазона значений в качестве параметра и Retuns VBA-Collection из уникальных источников-диапазона значений. В методе main функция вызывается и результат печатается в Output-Window. НТН.

исходный диапазон Образец выглядел следующим образом:

Option Explicit 

Sub main() 
    Dim uniques As Collection 
    Dim source As Range 

    Set source = ActiveSheet.Range("A2:F6") 
    Set uniques = GetUniqueValues(source.Value) 

    Dim it 
    For Each it In uniques 
     Debug.Print it 
    Next 
End Sub 

Public Function GetUniqueValues(ByVal values As Variant) As Collection 
    Dim result As Collection 
    Dim cellValue As Variant 
    Dim cellValueTrimmed As String 

    Set result = New Collection 
    Set GetUniqueValues = result 

    On Error Resume Next 

    For Each cellValue In values 
     cellValueTrimmed = Trim(cellValue) 
     If cellValueTrimmed = "" Then GoTo NextValue 
     result.Add cellValueTrimmed, cellValueTrimmed 
NextValue: 
    Next cellValue 

    On Error GoTo 0 
End Function 

Выход

SGD 
PHP 
KRW 
CNY 
IDA 
BGN 
PDSS 
CBBT 
INPC 
DBS 
a 

---

В случае, когда кислый диапазон диапазонов состоит из областей, которые сначала получают значения всех областей.

Public Function GetSourceValues(ByVal sourceRange As Range) As Collection 
    Dim vals As VBA.Collection 
    Dim area As Range 
    Dim val As Variant 
    Set vals = New VBA.Collection 
    For Each area In sourceRange.Areas 
     For Each val In area.Value 
      If val <> "" Then _ 
       vals.Add val 
     Next val 
    Next area 
    Set GetSourceValues = vals 
End Function 

Тип источника теперь Collection, но тогда все работает точно так же:

Dim uniques As Collection 
Dim source As Collection 

Set source = GetSourceValues(ActiveSheet.Range("A2:F6").SpecialCells(xlCellTypeVisible)) 
Set uniques = GetUniqueValues(source)