wake-up-neo.com

vba: Ermittelt eindeutige Werte aus dem Array

gibt es in vba integrierte Funktionen, um eindeutige Werte aus einem eindimensionalen Array zu erhalten? Was ist, wenn Sie nur Duplikate loswerden?

wenn nicht, wie würde ich dann die eindeutigen Werte aus einem Array erhalten?

Dieser Beitrag enthält 2 Beispiele. Ich mag den zweiten:

Sub unique() 
  Dim arr As New Collection, a 
  Dim aFirstArray() As Variant 
  Dim i As Long 

  aFirstArray() = Array("Banana", "Apple", "Orange", "Tomato", "Apple", _ 
  "Lemon", "Lime", "Lime", "Apple") 

  On Error Resume Next 
  For Each a In aFirstArray 
     arr.Add a, a 
  Next 

  For i = 1 To arr.Count 
     Cells(i, 1) = arr(i) 
  Next 

End Sub 
50
Doc Brown

Es gibt keine integrierte Funktion zum Entfernen von Duplikaten aus Arrays. Rajs Antwort scheint elegant, aber ich benutze lieber Wörterbücher.

Dim d As Object
Set d = CreateObject("Scripting.Dictionary")
'Set d = New Scripting.Dictionary

Dim i As Long
For i = LBound(myArray) To UBound(myArray)
    d(myArray(i)) = 1
Next i

Dim v As Variant
For Each v In d.Keys()
    'd.Keys() is a Variant array of the unique values in myArray.
    'v will iterate through each of them.
Next v

EDIT: Ich habe die Schleife geändert, um LBound und UBound gemäß der von Tomalak vorgeschlagenen Antwort zu verwenden EDIT: d.Keys() ist ein Variant-Array und keine Collection.

37
eksortso

Update (15.06.16)

Ich habe viel gründlichere Benchmarks erstellt. Wie @ChaimG hervorgehoben hat, macht das frühe Binden zunächst einen großen Unterschied (ich habe den Code von @ eksorto oben wörtlich verwendet, der spätes Binden verwendet). Zweitens beinhalteten meine ursprünglichen Benchmarks nur die Zeit zum Erstellen des eindeutigen Objekts. Die Effizienz der Verwendung des Objekts wurde jedoch nicht getestet. Mein Punkt dabei ist, dass es nicht wirklich wichtig ist, ob ich ein Objekt wirklich schnell erstellen kann, wenn das von mir erstellte Objekt klobig ist und mich beim Fortfahren verlangsamt.

Alte Bemerkung: Es stellt sich heraus, dass das Durchlaufen eines Sammlungsobjekts äußerst ineffizient ist.

Es stellt sich heraus, dass das Durchlaufen einer Sammlung sehr effizient sein kann, wenn Sie wissen, wie das gemacht wird (was ich nicht getan habe). Wie @ChaimG (noch einmal) in den Kommentaren hervorgehoben hat, ist die Verwendung eines For Each-Konstrukts der einfachen Verwendung einer For-Schleife lächerlich überlegen. Um Ihnen eine Idee zu geben, war vor dem Ändern des Schleifenkonstrukts die Zeit für Collection2 für Test Case Size = 10^6 über 1400s (d. H. ~ 23 Minuten). Es ist jetzt eine magere 0.195s (über 7000x schneller).

Für die Collection-Methode gibt es zwei Zeiten. Der erste (mein ursprünglicher Benchmark Collection1) zeigt die Zeit zum Erstellen des eindeutigen Objekts. Der zweite Teil (Collection2) zeigt die Zeit, um das Objekt zu durchlaufen (was sehr natürlich ist), um ein zurückgabefähiges Array zu erstellen, wie dies bei den anderen Funktionen der Fall ist.

In der nachstehenden Tabelle zeigt ein gelber Hintergrund an, dass er für diesen Testfall am schnellsten war, und Rot zeigt den langsamsten an ("Nicht getestete" Algorithmen werden ausgeschlossen). Die Gesamtzeit für die Collection-Methode ist die Summe aus Collection1 und Collection2. Türkis zeigt an, dass es unabhängig von der ursprünglichen Bestellung das schnellste war.

 Benchmarks5

Unten ist der ursprüngliche Algorithmus, den ich erstellt habe (ich habe ihn leicht modifiziert, beispielsweise instanziieren meinen eigenen Datentyp nicht mehr). Es gibt die eindeutigen Werte eines Arrays mit der ursprünglichen Reihenfolge in einer sehr respektablen Zeit zurück und kann für jeden Datentyp geändert werden. Außerhalb von IndexMethod ist dies der schnellste Algorithmus für sehr große Arrays.

Hier sind die Hauptgedanken hinter diesem Algorithmus:

  1. Indizieren Sie das Array
  2. Nach Werten sortieren
  3. Platzieren Sie identische Werte am Ende des Arrays und hacken Sie diese anschließend ab.
  4. Zum Schluss sortieren Sie nach Index.

Unten ist ein Beispiel:

Let myArray = (86, 100, 33, 19, 33, 703, 19, 100, 703, 19)

    1.  (86, 100, 33, 19, 33, 703, 19, 100, 703, 19)
        (1 ,   2,  3,  4,  5,   6,  7,   8,   9, 10)   <<-- Indexing

    2.  (19, 19, 19, 33, 33, 86, 100, 100, 703, 703)   <<-- sort by values     
        (4,   7, 10,  3,  5,  1,   2,   8,   6,   9)

    3.  (19, 33,  86, 100, 703)   <<-- remove duplicates    
        (4,   3,   1,   2,   6)

    4.  (86, 100,  33, 19, 703)   
        ( 1,   2,   3,  4,   6)   <<-- sort by index

Hier ist der Code:

Function SortingUniqueTest(ByRef myArray() As Long, bOrigIndex As Boolean) As Variant
    Dim MyUniqueArr() As Long, i As Long, intInd As Integer
    Dim StrtTime As Double, Endtime As Double, HighB As Long, LowB As Long

    LowB = LBound(myArray): HighB = UBound(myArray)

    ReDim MyUniqueArr(1 To 2, LowB To HighB)
    intInd = 1 - LowB  'Guarantees the indices span 1 to Lim

    For i = LowB To HighB
        MyUniqueArr(1, i) = myArray(i)
        MyUniqueArr(2, i) = i + intInd
    Next i

    QSLong2D MyUniqueArr, 1, LBound(MyUniqueArr, 2), UBound(MyUniqueArr, 2), 2
    Call UniqueArray2D(MyUniqueArr)
    If bOrigIndex Then QSLong2D MyUniqueArr, 2, LBound(MyUniqueArr, 2), UBound(MyUniqueArr, 2), 2

    SortingUniqueTest = MyUniqueArr()
End Function

Public Sub UniqueArray2D(ByRef myArray() As Long)
    Dim i As Long, j As Long, Count As Long, Count1 As Long, DuplicateArr() As Long
    Dim lngTemp As Long, HighB As Long, LowB As Long
    LowB = LBound(myArray, 2): Count = LowB: i = LowB: HighB = UBound(myArray, 2)

    Do While i < HighB
        j = i + 1
        If myArray(1, i) = myArray(1, j) Then
            Do While myArray(1, i) = myArray(1, j)
                ReDim Preserve DuplicateArr(1 To Count)
                DuplicateArr(Count) = j
                Count = Count + 1
                j = j + 1
                If j > HighB Then Exit Do
            Loop

            QSLong2D myArray, 2, i, j - 1, 2
        End If
        i = j
    Loop

    Count1 = HighB

    If Count > 1 Then
        For i = UBound(DuplicateArr) To LBound(DuplicateArr) Step -1
            myArray(1, DuplicateArr(i)) = myArray(1, Count1)
            myArray(2, DuplicateArr(i)) = myArray(2, Count1)
            Count1 = Count1 - 1
            ReDim Preserve myArray(1 To 2, LowB To Count1)
        Next i
    End If
End Sub

Hier ist der Sortieralgorithmus, den ich verwende (mehr zu diesem Algo hier ).

Sub QSLong2D(ByRef saArray() As Long, bytDim As Byte, lLow1 As Long, lHigh1 As Long, bytNum As Byte)
    Dim lLow2 As Long, lHigh2 As Long
    Dim sKey As Long, sSwap As Long, i As Byte

On Error GoTo ErrorExit

    If IsMissing(lLow1) Then lLow1 = LBound(saArray, bytDim)
    If IsMissing(lHigh1) Then lHigh1 = UBound(saArray, bytDim)
    lLow2 = lLow1
    lHigh2 = lHigh1

    sKey = saArray(bytDim, (lLow1 + lHigh1) \ 2)

    Do While lLow2 < lHigh2
        Do While saArray(bytDim, lLow2) < sKey And lLow2 < lHigh1: lLow2 = lLow2 + 1: Loop
        Do While saArray(bytDim, lHigh2) > sKey And lHigh2 > lLow1: lHigh2 = lHigh2 - 1: Loop

        If lLow2 < lHigh2 Then
            For i = 1 To bytNum
                sSwap = saArray(i, lLow2)
                saArray(i, lLow2) = saArray(i, lHigh2)
                saArray(i, lHigh2) = sSwap
            Next i
        End If

        If lLow2 <= lHigh2 Then
            lLow2 = lLow2 + 1
            lHigh2 = lHigh2 - 1
        End If
    Loop

    If lHigh2 > lLow1 Then QSLong2D saArray(), bytDim, lLow1, lHigh2, bytNum
    If lLow2 < lHigh1 Then QSLong2D saArray(), bytDim, lLow2, lHigh1, bytNum

ErrorExit:

End Sub

Nachfolgend finden Sie einen speziellen Algorithmus, der schnell ausläuft, wenn Ihre Daten Ganzzahlen enthalten. Es verwendet die Indizierung und den Datentyp Boolean.

Function IndexSort(ByRef myArray() As Long, bOrigIndex As Boolean) As Variant
'' Modified to take both positive and negative integers
    Dim arrVals() As Long, arrSort() As Long, arrBool() As Boolean
    Dim i As Long, HighB As Long, myMax As Long, myMin As Long, OffSet As Long
    Dim LowB As Long, myIndex As Long, count As Long, myRange As Long

    HighB = UBound(myArray)
    LowB = LBound(myArray)

    For i = LowB To HighB
        If myArray(i) > myMax Then myMax = myArray(i)
        If myArray(i) < myMin Then myMin = myArray(i)
    Next i

    OffSet = Abs(myMin)  '' Number that will be added to every element
                         '' to guarantee every index is non-negative

    If myMax > 0 Then
        myRange = myMax + OffSet  '' E.g. if myMax = 10 & myMin = -2, then myRange = 12
    Else
        myRange = OffSet
    End If

    If bOrigIndex Then
        ReDim arrSort(1 To 2, 1 To HighB)
        ReDim arrVals(1 To 2, 0 To myRange)
        ReDim arrBool(0 To myRange)

        For i = LowB To HighB
            myIndex = myArray(i) + OffSet
            arrBool(myIndex) = True
            arrVals(1, myIndex) = myArray(i)
            If arrVals(2, myIndex) = 0 Then arrVals(2, myIndex) = i
        Next i

        For i = 0 To myRange
            If arrBool(i) Then
                count = count + 1
                arrSort(1, count) = arrVals(1, i)
                arrSort(2, count) = arrVals(2, i)
            End If
        Next i

        QSLong2D arrSort, 2, 1, count, 2
        ReDim Preserve arrSort(1 To 2, 1 To count)
    Else
        ReDim arrSort(1 To HighB)
        ReDim arrVals(0 To myRange)
        ReDim arrBool(0 To myRange)

        For i = LowB To HighB
            myIndex = myArray(i) + OffSet
            arrBool(myIndex) = True
            arrVals(myIndex) = myArray(i)
        Next i

        For i = 0 To myRange
            If arrBool(i) Then
                count = count + 1
                arrSort(count) = arrVals(i)
            End If
        Next i

        ReDim Preserve arrSort(1 To count)
    End If

    ReDim arrVals(0)
    ReDim arrBool(0)

    IndexSort = arrSort
End Function

Hier sind die Funktionen Collection (by @DocBrown) und Dictionary (by @eksortso).

Function CollectionTest(ByRef arrIn() As Long, Lim As Long) As Variant
    Dim arr As New Collection, a, i As Long, arrOut() As Variant, aFirstArray As Variant
    Dim StrtTime As Double, EndTime1 As Double, EndTime2 As Double, count As Long
On Error Resume Next

    ReDim arrOut(1 To UBound(arrIn))
    ReDim aFirstArray(1 To UBound(arrIn))

    StrtTime = Timer
    For i = 1 To UBound(arrIn): aFirstArray(i) = CStr(arrIn(i)): Next i '' Convert to string
    For Each a In aFirstArray               ''' This part is actually creating the unique set
        arr.Add a, a
    Next
    EndTime1 = Timer - StrtTime

    StrtTime = Timer         ''' This part is writing back to an array for return
    For Each a In arr: count = count + 1: arrOut(count) = a: Next a
    EndTime2 = Timer - StrtTime
    CollectionTest = Array(arrOut, EndTime1, EndTime2)
End Function

Function DictionaryTest(ByRef myArray() As Long, Lim As Long) As Variant
    Dim StrtTime As Double, Endtime As Double
    Dim d As Scripting.Dictionary, i As Long  '' Early Binding
    Set d = New Scripting.Dictionary
    For i = LBound(myArray) To UBound(myArray): d(myArray(i)) = 1: Next i
    DictionaryTest = d.Keys()
End Function

Hier ist der direkte Ansatz von @IsraelHoletz.

Function ArrayUnique(ByRef aArrayIn() As Long) As Variant
    Dim aArrayOut() As Variant, bFlag As Boolean, vIn As Variant, vOut As Variant
    Dim i As Long, j As Long, k As Long
    ReDim aArrayOut(LBound(aArrayIn) To UBound(aArrayIn))
    i = LBound(aArrayIn)
    j = i

    For Each vIn In aArrayIn
        For k = j To i - 1
            If vIn = aArrayOut(k) Then bFlag = True: Exit For
        Next
        If Not bFlag Then aArrayOut(i) = vIn: i = i + 1
        bFlag = False
    Next

    If i <> UBound(aArrayIn) Then ReDim Preserve aArrayOut(LBound(aArrayIn) To i - 1)
    ArrayUnique = aArrayOut
End Function

Function DirectTest(ByRef aArray() As Long, Lim As Long) As Variant
    Dim aReturn() As Variant
    Dim StrtTime As Long, Endtime As Long, i As Long
    aReturn = ArrayUnique(aArray)
    DirectTest = aReturn
End Function

Hier ist die Benchmark-Funktion, die alle Funktionen vergleicht. Beachten Sie, dass die letzten beiden Fälle aufgrund von Speicherproblemen unterschiedlich behandelt werden. Beachten Sie auch, dass ich die Collection-Methode nicht für Test Case Size = 10,000,000 getestet habe. Aus irgendeinem Grund gab es falsche Ergebnisse zurück und verhielt sich ungewöhnlich (ich schätze, dass das Objekt der Sammlung ein Limit hat, wie viele Dinge Sie hineinlegen können. Ich habe danach gesucht und konnte keine Literatur finden).

Function UltimateTest(Lim As Long, bTestDirect As Boolean, bTestDictionary, bytCase As Byte) As Variant

    Dim dictionTest, collectTest, sortingTest1, indexTest1, directT '' all variants
    Dim arrTest() As Long, i As Long, bEquality As Boolean, SizeUnique As Long
    Dim myArray() As Long, StrtTime As Double, EndTime1 As Variant
    Dim EndTime2 As Double, EndTime3 As Variant, EndTime4 As Double
    Dim EndTime5 As Double, EndTime6 As Double, sortingTest2, indexTest2

    ReDim myArray(1 To Lim): Rnd (-2)   '' If you want to test negative numbers, 
    '' insert this to the left of CLng(Int(Lim... : (-1) ^ (Int(2 * Rnd())) *
    For i = LBound(myArray) To UBound(myArray): myArray(i) = CLng(Int(Lim * Rnd() + 1)): Next i
    arrTest = myArray

    If bytCase = 1 Then
        If bTestDictionary Then
            StrtTime = Timer: dictionTest = DictionaryTest(arrTest, Lim): EndTime1 = Timer - StrtTime
        Else
            EndTime1 = "Not Tested"
        End If

        arrTest = myArray
        collectTest = CollectionTest(arrTest, Lim)

        arrTest = myArray
        StrtTime = Timer: sortingTest1 = SortingUniqueTest(arrTest, True): EndTime2 = Timer - StrtTime
        SizeUnique = UBound(sortingTest1, 2)

        If bTestDirect Then
            arrTest = myArray: StrtTime = Timer: directT = DirectTest(arrTest, Lim): EndTime3 = Timer - StrtTime
        Else
            EndTime3 = "Not Tested"
        End If

        arrTest = myArray
        StrtTime = Timer: indexTest1 = IndexSort(arrTest, True): EndTime4 = Timer - StrtTime

        arrTest = myArray
        StrtTime = Timer: sortingTest2 = SortingUniqueTest(arrTest, False): EndTime5 = Timer - StrtTime

        arrTest = myArray
        StrtTime = Timer: indexTest2 = IndexSort(arrTest, False): EndTime6 = Timer - StrtTime

        bEquality = True
        For i = LBound(sortingTest1, 2) To UBound(sortingTest1, 2)
            If Not CLng(collectTest(0)(i)) = sortingTest1(1, i) Then
                bEquality = False
                Exit For
            End If
        Next i

        For i = LBound(dictionTest) To UBound(dictionTest)
            If Not dictionTest(i) = sortingTest1(1, i + 1) Then
                bEquality = False
                Exit For
            End If
        Next i

        For i = LBound(dictionTest) To UBound(dictionTest)
            If Not dictionTest(i) = indexTest1(1, i + 1) Then
                bEquality = False
                Exit For
            End If
        Next i

        If bTestDirect Then
            For i = LBound(dictionTest) To UBound(dictionTest)
                If Not dictionTest(i) = directT(i + 1) Then
                    bEquality = False
                    Exit For
                End If
            Next i
        End If

        UltimateTest = Array(bEquality, EndTime1, EndTime2, EndTime3, EndTime4, _
                        EndTime5, EndTime6, collectTest(1), collectTest(2), SizeUnique)
    ElseIf bytCase = 2 Then
        arrTest = myArray
        collectTest = CollectionTest(arrTest, Lim)
        UltimateTest = Array(collectTest(1), collectTest(2))
    ElseIf bytCase = 3 Then
        arrTest = myArray
        StrtTime = Timer: sortingTest1 = SortingUniqueTest(arrTest, True): EndTime2 = Timer - StrtTime
        SizeUnique = UBound(sortingTest1, 2)
        UltimateTest = Array(EndTime2, SizeUnique)
    ElseIf bytCase = 4 Then
        arrTest = myArray
        StrtTime = Timer: indexTest1 = IndexSort(arrTest, True): EndTime4 = Timer - StrtTime
        UltimateTest = EndTime4
    ElseIf bytCase = 5 Then
        arrTest = myArray
        StrtTime = Timer: sortingTest2 = SortingUniqueTest(arrTest, False): EndTime5 = Timer - StrtTime
        UltimateTest = EndTime5
    ElseIf bytCase = 6 Then
        arrTest = myArray
        StrtTime = Timer: indexTest2 = IndexSort(arrTest, False): EndTime6 = Timer - StrtTime
        UltimateTest = EndTime6
    End If

End Function

Und schließlich ist hier das U-Boot, das die Tabelle oben erzeugt.

Sub GetBenchmarks()
    Dim myVar, i As Long, TestCases As Variant, j As Long, temp

    TestCases = Array(1000, 5000, 10000, 20000, 50000, 100000, 200000, 500000, 1000000, 2000000, 5000000, 10000000)

    For j = 0 To 11
        If j < 6 Then
            myVar = UltimateTest(CLng(TestCases(j)), True, True, 1)
        ElseIf j < 10 Then
            myVar = UltimateTest(CLng(TestCases(j)), False, True, 1)
        ElseIf j < 11 Then
            myVar = Array("Not Tested", "Not Tested", 0.1, "Not Tested", 0.1, 0.1, 0.1, 0, 0, 0)
            temp = UltimateTest(CLng(TestCases(j)), False, False, 2)
            myVar(7) = temp(0): myVar(8) = temp(1)
            temp = UltimateTest(CLng(TestCases(j)), False, False, 3)
            myVar(2) = temp(0): myVar(9) = temp(1)
            myVar(4) = UltimateTest(CLng(TestCases(j)), False, False, 4)
            myVar(5) = UltimateTest(CLng(TestCases(j)), False, False, 5)
            myVar(6) = UltimateTest(CLng(TestCases(j)), False, False, 6)
        Else
            myVar = Array("Not Tested", "Not Tested", 0.1, "Not Tested", 0.1, 0.1, 0.1, "Not Tested", "Not Tested", 0)
            temp = UltimateTest(CLng(TestCases(j)), False, False, 3)
            myVar(2) = temp(0): myVar(9) = temp(1)
            myVar(4) = UltimateTest(CLng(TestCases(j)), False, False, 4)
            myVar(5) = UltimateTest(CLng(TestCases(j)), False, False, 5)
            myVar(6) = UltimateTest(CLng(TestCases(j)), False, False, 6)
        End If

        Cells(4 + j, 6) = TestCases(j)
        For i = 1 To 9: Cells(4 + j, 6 + i) = myVar(i - 1): Next i
        Cells(4 + j, 17) = myVar(9)
    Next j
End Sub

Zusammenfassung
Aus der Ergebnistabelle kann man ersehen, dass die Dictionary-Methode für Fälle von weniger als etwa 500.000 wirklich gut funktioniert, aber danach beginnt die IndexMethod wirklich zu dominieren. Sie werden feststellen, dass wenn die Reihenfolge keine Rolle spielt und Ihre Daten aus positiven Ganzzahlen bestehen, kein Vergleich mit dem IndexMethod-Algorithmus möglich ist (es werden die eindeutigen Werte eines Arrays mit 10 Millionen Elementen in weniger als 1 Sekunde zurückgegeben.) Unglaublich !). Nachfolgend habe ich eine Aufschlüsselung, welcher Algorithmus in verschiedenen Fällen bevorzugt wird.

Fall 1
Ihre Daten enthalten ganze Zahlen (d. H. Sowohl positive als auch negative ganze Zahlen): IndexMethod

Fall 2
Ihre Daten enthalten Nicht-Ganzzahlen (d. H. Variante, Double, String usw.) mit weniger als 200000 Elementen: Dictionary Method

Fall 3
Ihre Daten enthalten Nicht-Ganzzahlen (d. H. Variante, Double, String usw.) mit mehr als 200000 Elementen: Collection Method

Wenn Sie einen Algorithmus wählen müssten, ist die Collection-Methode meiner Meinung nach immer noch die beste Methode, da nur wenige Zeilen Code erforderlich sind. Sie ist super allgemein und sie ist schnell genug.

17
Joseph Wood

Nein, nichts eingebaut. Mach es selbst:

  • Instanziieren eines Scripting.Dictionary-Objekts
  • Schreiben Sie eine For-Schleife über Ihr Array (verwenden Sie LBound() und UBound(), anstatt von 0 nach x zu schleifen!).
  • Überprüfen Sie bei jeder Wiederholung Exists() im Wörterbuch. Fügen Sie jeden Array-Wert (der noch nicht vorhanden ist) als Schlüssel zum Wörterbuch hinzu (verwenden Sie CStr(), da Schlüssel Zeichenfolgen sein müssen Wie ich gerade erfahren habe, können Schlüssel in einem Scripting.Dictionary) von beliebigem Typ sein. Außerdem wird der Array-Wert selbst im Wörterbuch gespeichert.
  • Wenn Sie fertig sind, verwenden Sie Keys() (oder Items()), um alle Werte des Wörterbuchs als neues, jetzt einzigartiges Array zurückzugeben.
  • In meinen Tests behält das Wörterbuch die ursprüngliche Reihenfolge aller hinzugefügten Werte bei, sodass die Ausgabe wie bei der Eingabe angeordnet wird. Ich bin nicht sicher, ob dies dokumentiertes und zuverlässiges Verhalten ist.
3
Tomalak

Ich kenne keine integrierte Funktionalität in VBA. Am besten verwenden Sie eine Auflistung, die den Wert als Schlüssel verwendet, und nur dann hinzufügen, wenn kein Wert vorhanden ist.

2
Raj

Nein, VBA verfügt nicht über diese Funktionalität. Sie können die Technik verwenden, um jedes Element einer Sammlung hinzuzufügen, indem Sie das Element als Schlüssel verwenden. Da eine Sammlung keine doppelten Schlüssel zulässt, sind unterschiedliche Werte, die Sie bei Bedarf in ein Array kopieren können.

Sie möchten vielleicht auch etwas robuster. Siehe Funktion für eindeutige Werte unter http://www.cpearson.com/Excel/distinctvalues.aspx

Einzelne Werte Funktion

Eine VBA-Funktion, die ein .__ zurückgibt. Array der verschiedenen Werte in einem Bereich oder Array von Eingabewerten.

Excel verfügt über einige manuelle Methoden, z. B. Erweiterter Filter, um eine Liste mit Abzurufen. verschiedene Elemente aus einem Eingabebereich . Der Nachteil solcher Methoden ist dass Sie die .__ manuell aktualisieren müssen. ergibt sich, wenn sich die Eingabedaten ändern . Darüber hinaus funktionieren diese Methoden nur mit Bereiche, nicht Wertebereiche und nicht Funktionen können nicht aus .__ aufgerufen werden. Arbeitsblattzellen oder integriert in Array-Formeln. Diese Seite beschreibt ein VBA-Funktion namens DistinctValues ​​ das akzeptiert entweder einen Bereich oder ein Array von Daten und gibt es als .__ zurück. Ergebnis ein Array mit der verschiedene Elemente aus der Eingabeliste . Das heißt, die Elemente mit allen Duplikate entfernt. Die Reihenfolge der Eingabeelemente bleiben erhalten. Die Bestellung der Elemente im Ausgabearray ist die gleiche Reihenfolge wie in der Eingabe Werte. Die Funktion kann aufgerufen werden aus einem von Array angegebenen Bereich auf einem Arbeitsblatt (siehe diese Seite für Informationen zu Arrayformeln) oder von in einer Arrayformel in einer einzelnen Arbeitsblattzelle oder aus einer anderen VB Funktion.

2
AMissico

Wenn die Reihenfolge des deduplizierten Arrays für Sie keine Rolle spielt, können Sie meine pragmatische Funktion verwenden:

Function DeDupArray(ia() As String)
  Dim newa() As String
  ReDim newa(999)
  ni = -1
  For n = LBound(ia) To UBound(ia)
    dup = False
    If n <= UBound(ia) Then
      For k = n + 1 To UBound(ia)
        If ia(k) = ia(n) Then dup = True
      Next k

      If dup = False And Trim(ia(n)) <> "" Then
        ni = ni + 1
        newa(ni) = ia(n)
      End If
    End If
  Next n

  If ni > -1 Then
    ReDim Preserve newa(ni)
  Else
    ReDim Preserve newa(1)
  End If

  DeDupArray = newa
End Function



Sub testdedup()
Dim m(5) As String
Dim m2() As String

m(0) = "Horse"
m(1) = "Cow"
m(2) = "Dear"
m(3) = "Horse"
m(4) = "Joke"
m(5) = "Cow"

m2 = DeDupArray(m)
t = ""
For n = LBound(m2) To UBound(m2)
  t = t & n & "=" & m2(n) & " "
Next n
MsgBox t
End Sub

Aus der Testfunktion ergibt sich das folgende deduplizierte Array:

"0 = Lieber 1 = Pferd 2 = Witz 3 = Kuh"

0
Rob de Leeuw

Die Collection- und Dictionary-Lösungen sind allesamt nett und für einen kurzen Ansatz geeignet. Wenn Sie jedoch Geschwindigkeit wünschen, versuchen Sie es mit einem direkteren Ansatz:

Function ArrayUnique(ByVal aArrayIn As Variant) As Variant
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' ArrayUnique
' This function removes duplicated values from a single dimension array
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim aArrayOut() As Variant
Dim bFlag As Boolean
Dim vIn As Variant
Dim vOut As Variant
Dim i%, j%, k%

ReDim aArrayOut(LBound(aArrayIn) To UBound(aArrayIn))
i = LBound(aArrayIn)
j = i

For Each vIn In aArrayIn
    For k = j To i - 1
        If vIn = aArrayOut(k) Then bFlag = True: Exit For
    Next
    If Not bFlag Then aArrayOut(i) = vIn: i = i + 1
    bFlag = False
Next

If i <> UBound(aArrayIn) Then ReDim Preserve aArrayOut(LBound(aArrayIn) To i - 1)
ArrayUnique = aArrayOut
End Function

Ich nenne es:

Sub Test()
Dim aReturn As Variant
Dim aArray As Variant

aArray = Array(1, 2, 3, 1, 2, 3, "Test", "Test")
aReturn = ArrayUnique(aArray)
End Sub

Für den Vergleich der Geschwindigkeit ist dies 100x bis 130x schneller als die Wörterbuchlösung, und etwa 8000x bis 13000x schneller als die Erfassungslösung.

0
Israel Holetz

Es gibt keine integrierte VBA-Funktion zum Entfernen von Duplikaten aus einem Array. Sie können jedoch die nächste Funktion verwenden:

Function RemoveDuplicates(MyArray As Variant) As Variant
    With CreateObject("scripting.dictionary")
        For Each item In MyArray
            c00 = .Item(item)
        Next
        sn = .keys ' the array .keys contains all unique keys
        MsgBox Join(.keys, vbLf) ' you can join the array into a string
        RemoveDuplicates = .keys ' return an array without duplicates
    End With
End Function
0
Sergei