web-dev-qa-db-fra.com

vba: obtenir des valeurs uniques d'un tableau

y a-t-il une fonctionnalité intégrée dans vba pour obtenir des valeurs uniques à partir d'un tableau à une dimension? Qu'en est-il de se débarrasser des doublons?

sinon, comment pourrais-je obtenir les valeurs uniques d'un tableau?

excelvbaexcel-vba
42
l--''''''---------''''''''''''

Cet article contient 2 exemples. J'aime le 2ème:

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

Aucune fonctionnalité intégrée ne permet de supprimer les doublons des tableaux. La réponse de Raj semble élégante, mais je préfère utiliser des dictionnaires.

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: j'ai modifié la boucle pour utiliser LBound et UBound conformément à la réponse suggérée par Tomalak . EDIT: d.Keys() est un tableau de variants, pas une collection.

37
eksortso

Mise à jour (15/06/16)

J'ai créé des repères beaucoup plus approfondis. Tout d’abord, comme @ChaimG l’a souligné, la liaison précoce fait une grande différence (j’avais initialement utilisé le code de @ eksortso ci-dessus, mot pour mot, qui utilise une liaison tardive). Deuxièmement, mes repères initiaux n'incluaient que le temps nécessaire pour créer l'objet unique. Cependant, ils ne testaient pas l'efficacité de l'utilisation de l'objet. Ce que je veux dire par là, c’est que peu importe si je peux créer un objet très rapidement si l’objet que je crée est maladroit et me ralentit.

Vieille remarque: il s'avère que la boucle sur un objet de collection est très inefficace

Il s'avère que boucler sur une collection peut être assez efficace si vous savez le faire (je ne l'ai pas fait). Comme @ChaimG (encore une fois), a souligné dans les commentaires, utiliser une construction For Each est ridiculement supérieur à simplement utiliser une boucle For. Pour vous donner une idée, avant de changer la construction de la boucle, le temps pour Collection2 pour le Test Case Size = 10^6 était supérieur à 1400 (c'est-à-dire ~ 23 minutes). C'est maintenant un maigre 0.195s (plus de 7000x plus rapide).

Pour la méthode Collection, il y a deux fois. Le premier (mon repère d'origine Collection1) indique l'heure à laquelle créer l'objet unique. La deuxième partie (Collection2) indique le temps nécessaire pour boucler sur l'objet (ce qui est très naturel) pour créer un tableau retournable comme le font les autres fonctions.

Dans le tableau ci-dessous, un arrière-plan jaune indique qu'il était le plus rapide pour ce scénario de test et le rouge indique le plus lent (les algorithmes "non testés" sont exclus). La durée totale de la méthode Collection est la somme de Collection1 et Collection2. Turquoise indique que c'était le plus rapide, quelle que soit la commande originale.

 Benchmarks5

Vous trouverez ci-dessous l'algorithme d'origine que j'ai créé (je l'ai légèrement modifié, par exemple, je n'instancie plus mon propre type de données). Il renvoie les valeurs uniques d'un tableau avec l'ordre d'origine dans un temps très respectable et peut être modifié pour prendre n'importe quel type de données. En dehors de IndexMethod, c'est l'algorithme le plus rapide pour les très grands tableaux.

Voici les idées principales derrière cet algorithme:

  1. Indexer le tableau
  2. Trier par valeurs
  3. Placez des valeurs identiques à la fin du tableau et ensuite "les couper".
  4. Enfin, triez par index.

En voici un exemple:

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

Voici le 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

Voici l'algorithme de tri que j'utilise (plus sur cet algo ici ).

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

Vous trouverez ci-dessous un algorithme spécial qui accélère rapidement si vos données contiennent des entiers. Il utilise l'indexation et le type de données booléen.

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

Voici les fonctions Collection (par @DocBrown) et Dictionnaire (par @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

Voici l'approche directe fournie par @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

Voici la fonction de référence qui compare toutes les fonctions. Notez que les deux derniers cas sont traités un peu différemment à cause de problèmes de mémoire. Notez également que je n’ai pas testé la méthode Collection pour le Test Case Size = 10,000,000. Pour une raison quelconque, il renvoyait des résultats incorrects et se comportait de manière inhabituelle (je suppose que l'objet collection a une limite sur le nombre d'éléments que vous pouvez y insérer. J'ai cherché et je n'ai trouvé aucune littérature à ce sujet).

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

Et enfin, voici le sous qui produit le tableau ci-dessus.

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

Résumé
D'après le tableau des résultats, nous pouvons constater que la méthode Dictionary fonctionne très bien pour les cas inférieurs à environ 500 000. Cependant, après cela, la variable IndexMethod commence réellement à dominer. Vous remarquerez que lorsque l'ordre n'a pas d'importance et que vos données sont composées d'entiers positifs, il n'y a aucune comparaison avec l'algorithme IndexMethod (il renvoie les valeurs uniques d'un tableau contenant 10 millions d'éléments en moins de 1 seconde !!! Incredible !) Ci-dessous, je présente une ventilation de l'algorithme préféré dans divers cas.

Cas 1
Vos données contiennent des nombres entiers (c’est-à-dire des nombres entiers, positifs et négatifs): IndexMethod

Cas 2
Vos données contiennent des nombres non entiers (c.-à-d. Variant, double, chaîne, etc.) de moins de 200 000 éléments: Dictionary Method

Cas 3
Vos données contiennent des nombres non entiers (c.-à-d. Variant, double, chaîne, etc.) comportant plus de 200 000 éléments: Collection Method

Si vous deviez choisir un algorithme, à mon avis, la méthode Collection est toujours la meilleure car elle ne nécessite que quelques lignes de code, elle est super générale et assez rapide.

17
Joseph Wood

Non, rien d'intégré. Fais le toi-même:

  • Instancier un objet Scripting.Dictionary
  • Ecrivez une boucle For sur votre tableau (veillez à utiliser LBound() et UBound() au lieu de boucler de 0 à x!)
  • À chaque itération, cochez Exists() dans le dictionnaire. Ajoutez chaque valeur de tableau (qui n'existe pas déjà) en tant que clé du dictionnaire (utilisez CStr() puisque les clés doivent être des chaînes comme je viens de l'apprendre, les clés peuvent être de n'importe quel type dans un Scripting.Dictionary), stockent également la valeur du tableau dans le dictionnaire.
  • Une fois terminé, utilisez Keys() (ou Items()) pour renvoyer toutes les valeurs du dictionnaire sous la forme d'un nouveau tableau, désormais unique.
  • Dans mes tests, le dictionnaire conserve l'ordre d'origine de toutes les valeurs ajoutées. La sortie sera donc ordonnée comme auparavant. Je ne suis pas sûr que ce soit un comportement documenté et fiable, cependant.
3
Tomalak

Je ne connais aucune fonctionnalité intégrée à VBA. Le mieux serait d'utiliser une collection utilisant la valeur comme clé et de ne l'ajouter que si une valeur n'existe pas.

2
Raj

Non, VBA ne dispose pas de cette fonctionnalité. Vous pouvez utiliser la technique consistant à ajouter chaque élément à une collection en utilisant l'élément comme clé. Dans la mesure où une collection n'autorise pas les clés en double, le résultat est des valeurs distinctes que vous pouvez copier dans un tableau, si nécessaire.

Vous voudrez peut-être aussi quelque chose de plus robuste. Voir Fonction Valeurs Distinctes sur http://www.cpearson.com/Excel/distinctvalues.aspx

Fonction valeurs distinctes

Une fonction VBA qui retournera un tableau des valeurs distinctes dans un plage ou tableau de valeurs d'entrée.

Excel utilise des méthodes manuelles, telles que Filtre avancé, pour obtenir une liste de éléments distincts d'une plage d'entrée . L'inconvénient d'utiliser de telles méthodes est que vous devez actualiser manuellement le fichier résulte lorsque les données d'entrée changent . De plus, ces méthodes ne fonctionnent qu'avec plages, pas des tableaux de valeurs, et, pas étant des fonctions, ne peut pas être appelé à partir de cellules de la feuille de calcul ou incorporés dans formules de tableau. Cette page décrit un Fonction VBA appelée DistinctValues ​​ qui accepte en entrée soit une plage ou un tableau de données et renvoie sous la forme résulte un tableau contenant le éléments distincts de la liste d'entrée . C'est-à-dire les éléments avec tout doublons enlevés. L'ordre du les éléments d’entrée sont préservés. L'ordre des éléments dans le tableau de sortie est identique à l'ordre dans l'entrée valeurs. La fonction peut être appelée à partir d'un tableau entré gamme sur un feuille de calcul (voir cette page pour des informations sur les formules de tableau ), ou à partir d'une formule matricielle en un seul cellule de feuille de calcul, ou à partir d'un autre VB une fonction.

2
AMissico

Si l'ordre du tableau dédupliqué ne vous concerne pas, vous pouvez utiliser ma fonction pragmatique:

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

A partir de la fonction test, le tableau dédupliqué suivant sera créé:

"0 = cher 1 = cheval 2 = plaisanterie 3 = vache"

0
Rob de Leeuw

Les solutions Collection et Dictionnaire sont toutes belles et brillantes pour une approche courte, mais si vous voulez la vitesse, essayez une approche plus directe:

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

L'appelant:

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

Pour une comparaison de vitesse, ce sera 100x à 130x plus rapide que la solution de dictionnaire, et environ 8000x à 13000x plus rapide que celui de la collection.

0
Israel Holetz

Il n'y a pas de fonctionnalité VBA intégrée pour supprimer les doublons d'un tableau, mais vous pouvez utiliser la fonction suivante:

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