Wie erhalte ich eine Liste von eindeutigen Werten aus einem Bereich in Excel VBA?

Question

Ich möchte eine Liste der eindeutigen Werte in einem Bereich mit VBA erhalten. Die meisten Beispiele in Google sprechen über das Abrufen einer Liste eindeutiger Werte in einer Spalte mithilfe von VBA.

Ich bin mir nicht sicher, wie man es ändert, um eine Werteliste in einem Bereich zu erhalten.

Zum Beispiel

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

Mein Array soll wie folgt aussehen:

BGN, DBS, PDSS, CBBT and INPC. 

Wie kann ich es tun? Brauchen Sie etwas Anleitung.

Answer 1

Durchlaufen Sie den Bereich, überprüfen Sie, ob der Wert im Array ist, und fügen Sie ihn dem Array hinzu.

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

Ich würde eine einfache VBA-Collection verwenden und Elemente mit Schlüssel hinzufügen. Der Schlüssel wäre das Element selbst und da es keine doppelten Schlüssel geben kann, enthält die Sammlung eindeutige Werte.

Hinweis: Da das Hinzufügen eines doppelten Schlüssels zur Sammlung einen Fehler auslöst, wird der Aufruf von collection-add in eine on-error-resume-next-Nachricht eingeschlossen.

Die Funktion GetUniqueValues hat Source-Bereich-Werte als Parameter und Retuns VBA-Collection von einzigartigem Quelle-Bereich-Wert. In der main Methode wird die Funktion aufgerufen und das Ergebnis wird in das Ausgabefenster gedruckt. HTH.

Beispielquellbereich sah wie folgt aus:

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 

Ausgabe

SGD 
PHP 
KRW 
CNY 
IDA 
BGN 
PDSS 
CBBT 
INPC 
DBS 
a 

---

Im Fall, wenn die so urce Bereich besteht aus Bereichen erhalten Sie zuerst die Werte aller Bereiche.

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 

Quelltyp ist jetzt Sammlung aber dann funktioniert alles gleich:

Dim uniques As Collection 
Dim source As Collection 

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