vba: obtenir des valeurs uniques à partir du tableau
y a-t-il une fonctionnalité intégrée dans vba pour obtenir des valeurs uniques à partir d'un tableau unidimensionnel? qu'en est juste se débarrasser des doublons?
si non, Comment puis-je obtenir les valeurs uniques d'un tableau?
8 réponses
Ce post contient 2 exemples. J'aime bien 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
il n'y a pas de fonctionnalité intégrée pour 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 changé la boucle à utiliser LBound
et UBound
selon la réponse suggérée par Tomalak.
EDIT: d.Keys()
est une variante du tableau, pas une Collection.
mise à Jour (6/15/16)
j'ai créé des repères beaucoup plus précis. Tout d'abord, comme @ChaimG l'a souligné, la reliure précoce fait une grande différence (j'ai utilisé à l'origine le code de @eksortso ci-dessus mot à mot qui utilise la reliure tardive). Deuxièmement, mes repères originaux inclus seulement le temps de créer un objet unique, cependant, il n'a pas tester l'efficacité de l'aide de l'objet. Ce que je veux dire par là, c'est que ça n'a pas vraiment d'importance si je peux créer un objet très rapidement si l'objet create est clunky et me ralentit en avançant.
Ancien Remarque: il s'avère que le bouclage d'un objet de collection est très inefficace
il s'avère que boucler une collection peut être très efficace si vous savez comment le faire (Je ne l'ai pas fait). Comme @ChaimG (encore une fois), l'a souligné dans les commentaires, en utilisant un For Each
la construction est ridiculement supérieure à l'utilisation d'un For
boucle. Pour vous donner une idée, avant de changer la boucle de construire, le temps pour Collection2
pour les Test Case Size = 10^6
était plus de 1400 (C.-à-d. ~23 minutes). Il est maintenant un meager 0.195 s (plus de 7000x plus rapide).
pour le Collection
méthode il y a deux fois. Le premier (mon premier test Collection1
) affiche le temps de créer l'objet unique. La deuxième partie (Collection2
) montre le temps de boucle sur l'objet (ce qui est très naturel) pour créer un tableau récupérable comme le font les autres fonctions.
Dans le tableau ci-dessous, un fond jaune indique qu'il a été le plus rapide pour ce cas d'essai, et le Rouge indique le plus lent (les algorithmes "non testé" sont exclus). Le temps total pour l' Collection
méthode est la somme de Collection1
et Collection2
. Turquoise indique que is était le plus rapide indépendamment de l'ordre d'origine.
ci-dessous est l'algorithme original que j'ai créé (je l'ai légèrement modifié, par exemple je n'instancie plus mon propre type de données). Il retourne les valeurs uniques d'un tableau avec l'ordre original dans un temps très respectable et il peut être modifié pour prendre sur n'importe quel type de données. En dehors de l' IndexMethod
, c'est l'algorithme le plus rapide pour les très grands tableaux.
Voici les principales idées derrière cet algorithme:
- Index du tableau
- Trier par valeurs
- placer des valeurs identiques à la fin du tableau et ensuite les "couper".
- Enfin, trier par index.
ci-dessous est 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 j'utilise (en savoir 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
ci-dessous est un algorithme spécial qui brûle 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 (by @DocBrown) et 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
Voici l'approche directe fourni 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 benchmark qui compare toutes les fonctions. Vous devriez noter que les deux derniers cas sont traités un peu différente en raison de problèmes de mémoire. Notez aussi que je n'ai pas testé le Collection
méthode Test Case Size = 10,000,000
. Pour une raison quelconque, il retournait des résultats incorrects et se comporter inhabituel (je devine que l'objet de collecte a une limite sur le nombre de choses que vous pouvez y mettre. J'ai cherché et je ne pouvais pas trouver tout de la littérature sur cette).
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-marin 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é
Dans le tableau de résultats, nous pouvons voir que le Dictionary
la méthode fonctionne vraiment bien pour les cas de moins de 500,000, cependant, après cela, le IndexMethod
commence vraiment à dominer. Vous remarquerez que lorsque l'ordre n'a pas d'importance et de vos données est constituée d'entiers positifs, il n'y a pas de comparaison à l' IndexMethod
algorithme (il renvoie les valeurs uniques d'un tableau contenant 10 millions d'éléments en moins de 1 seconde!!! Incroyable!). Ci-dessous, j'ai une ventilation de quel algorithme est préféré dans divers cas.
Cas 1
Vos données contiennent des entiers (c'est-à-dire des nombres entiers, positifs et négatifs):IndexMethod
cas 2
Vos données contiennent des non-entiers (i.e. variant, double, string, etc. avec moins de 200000 éléments: Dictionary Method
cas 3
Vos données contiennent des non-entiers (i.e. variant, double, string, etc. avec plus de 200000 éléments: Collection Method
si vous deviez choisir un algorithme, à mon avis, le Collection
méthode est la meilleure car elle ne nécessite que quelques lignes de code, c'est super général, et il est assez rapide.
Non, rien d'incorporé. Le faire vous-même:
- Instancier un
Scripting.Dictionary
objet - Ecrire un
For
boucle sur votre tableau (assurez-vous d'utiliserLBound()
etUBound()
au lieu de boucler de 0 à x!) - a chaque itération, cochez
Exists()
sur le dictionnaire. Ajouter chaque valeur du tableau (qui n'existe pas déjà) comme clé du dictionnaire (utilisercomme je viens de l'apprendre, les clés peuvent être de n'importe quel type dans unCStr()
puisque les clés doivent être des chaînes de caractèresScripting.Dictionary
), stockez aussi la valeur du tableau elle-même dans le dictionnaire. - si vous avez terminé, utilisez
Keys()
(ouItems()
) pour retourner toutes les valeurs du dictionnaire comme un nouveau tableau, maintenant unique. - dans mes tests, le dictionnaire garde l'ordre original de toutes les valeurs ajoutées, donc la sortie sera ordonnée comme l'entrée était. Je ne suis pas sûr que ce soit documenté et un comportement fiable, cependant.
Je ne connais aucune fonctionnalité intégrée dans VBA. Le mieux serait d'utiliser une collection en utilisant la valeur comme clé et d'y ajouter seulement si une valeur n'existe pas.
Non, VBA n'a pas cette fonctionnalité. Vous pouvez utiliser la technique d'ajouter chaque article à une collection en utilisant l'article comme la clé. Puisqu'une collection ne permet pas les clés dupliquées, le résultat est des valeurs distinctes que vous pouvez copier dans un tableau, si nécessaire.
vous pouvez aussi vouloir quelque chose de plus robuste. Voir Fonction Des Valeurs Distincteshttp://www.cpearson.com/excel/distinctvalues.aspx
Valeurs Distinctes La fonction
une fonction VBA qui renverra une tableau de valeurs distinctes dans un gamme ou un tableau de valeurs d'entrée.
Excel a quelques méthodes manuelles, telles que Filtre avancé, pour obtenir une liste de éléments distincts d'une gamme d'entrées. L'inconvénient de ces méthodes est que vous devez rafraîchir manuellement le résultats lorsque les données d'entrée des changements. De plus, ces méthodes ne fonctionnent qu'avec et non pas des tableaux de valeurs être fonctions, ne peut pas être appelé de cellules de feuille de travail ou incorporées dans les formules de tableau. Cette page décrit un Fonction VBA appelée DistinctValues qui accepte en entrée une plage ou un tableau de données et renvoie comme résultat un tableau contenant les articles distincts de la liste d'entrée. C'est, avec tous les éléments les doublons supprimés. L'ordre de la éléments d'entrée est conservée. Ordre des éléments dans le tableau de sortie est le même que l'ordre dans l'entrée valeur. La fonction peut être appelée d'un tableau entre la portée sur un feuille de travail (voir cette page pour informations sur les formules de matrice), ou de dans une formule matricielle dans un seul cellule de la feuille de travail, ou à partir d'un autre VB fonction.
la Collection et les solutions de dictionnaire sont toutes belles et brillent pour une approche courte, mais si vous voulez la vitesse essayer d'utiliser 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'Appeler:
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 la 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.
si l'ordre du tableau désduplicated n'a pas d'importance pour vous, 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
à partir de la fonction test, il en résultera le tableau suivant:
"0=Cher 1=Cheval 2=Blague 3=La Vache "