Printable View
I'm trying to get all of the unique elements from an array using vba in excel. Here's the pseudo code for what I'm trying to do in vba.
array '<-- Array with redundant elements
uniqueArray '<-- Array with unique elements
for each element of array
if element not in uniqueArray
uniqueArray.append(element)
else
do nothing
Welcome to VBAX.
Look up the Dictionary Object or Collection in VBA help. If you need more assistance, please ask.
Greetings darkmatter,
There may be better/faster ways of doing this, but if you are looking for a basic example to see how this can be done:
In a standard module, paste:
[vba]Sub GetUnique()
Dim aFirstArray() As Variant
Dim aUniqueArray() As String
Dim lngCountFirst As Long
Dim lngCountUnique As Long
Dim bolFoundIt As Boolean
Dim strOne As String
Dim strTwo As String
'// add some values (some duplicated) to the first array//
aFirstArray() = Array("Banana", "Apple", "Orange", "Tomato", "Apple", _
"Lemon", "Lime", "Lime", "Apple")
'// Redim with one element, empty at this point.//
ReDim aUniqueArray(0)
'// loop thru ea element in our first array. (This is our outer loop)//
For lngCountFirst = LBound(aFirstArray()) To UBound(aFirstArray())
'// ensure that we flag as False at the start of ea loop//
bolFoundIt = False
'// In a secondary, inner loop, we can build the unique array, only //
'// adding items that have not already been added. //
For lngCountUnique = LBound(aUniqueArray()) To UBound(aUniqueArray())
'// For ea element in our unique array, see if it matches the //
'// current element being looked at in our frist array. If we //
'// find a match, mark our flag/boolean and exit the inner loop.//
'// On the other hand, if no match is found after every element //
'// in our unique array is looked at, then bolFoundIt will still//
'// be False. //
If aUniqueArray(lngCountUnique) = aFirstArray(lngCountFirst) Then
bolFoundIt = True
Exit For
End If
Next lngCountUnique
'// Now if bolFound is still False, then we didn't find a match, so //
'// we'll add it to the last available element in our unique array //
'// and add another empty element to the unique array for the next //
'// round... Note the use of Redim Preserve, so that we don't //
'// lose the values already added. //
If Not bolFoundIt Then
aUniqueArray(UBound(aUniqueArray())) = aFirstArray(lngCountFirst)
ReDim Preserve aUniqueArray(UBound(aUniqueArray()) + 1)
End If
Next lngCountFirst
'// Now after we're all done, we left our unique array with one //
'// extra/unused element. We'll drop/kill the extra element here. //
ReDim Preserve aUniqueArray(UBound(aUniqueArray()) - 1)
'// Just for the demo, we'll loop thru both arrays and build strings, //
'// then display the comparison in a msgbox //
For lngCountFirst = LBound(aFirstArray()) To UBound(aFirstArray())
strOne = strOne & aFirstArray(lngCountFirst) & vbCrLf
Next
For lngCountUnique = LBound(aUniqueArray()) To UBound(aUniqueArray())
strTwo = strTwo & aUniqueArray(lngCountUnique) & vbCrLf
Next
MsgBox "First array was:" & vbCrLf & strOne & String(2, vbCrLf) & _
"Second array is:" & vbCrLf & strTwo, 0, ""
End Sub[/vba]
Hope this helps,
Mark
[VBA] Option Base 1
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
[/VBA]
@mdmackillop:
Hi Malcom :-)
I had never used the collection object, and when I read the help topic (at home, so in 2000), I didn't 'get' using the error along with the key.
Even the times I had seen (here) collections being referred to I had just not grasped this. Thank you so much for the example, that is just awful nifty!
Thanks again,
Mark
It's very useful. Note that the Key has to be a string, so with numbers
[VBA]
aFirstArray() = Array(12, 5, 8, 6, 4, 8)
On Error Resume Next
For Each a In aFirstArray
arr.Add a, Str(a)
Next[/VBA]
Thanks again brother, :beerchug: duly noted and appreciated.
Mark
(Of course "noted" in my case is oft closer to "chanted like a mantra until jambed into my thick noggin...")
Here is a dictionary method. Be sure to set the reference. I removed all empty elements as well.
[VBA]
Sub Test_UniqueArray()
Dim a As Variant
a = Array("", "", "Banana", "Apple", "Orange", "Tomato", _
"Apple", "Lemon", "Lime", "Lime", "Apple", 1, 2, 3, 4, 1, 2)
a = UniqueArray(a)
Range("A1").Resize(UBound(a) + 1).Value = WorksheetFunction.Transpose(a)
End Sub
Function UniqueArray(anArray As Variant) As Variant
'Requires, Tools > Reference > Microsoft Scripting Runtime, scrrun.dll
Dim d As New Scripting.Dictionary, a As Variant
With d
.CompareMode = TextCompare
For Each a In anArray
If Not Len(a) = 0 And Not .Exists(a) Then
.Add a, Nothing
End If
Next a
UniqueArray = d.keys
End With
Set d = Nothing
End Function[/VBA]
Not sure about this.Please explaine me ..
Did you try the code?
or simply
[vba]
Sub M_snb()
With CreateObject("scripting.dictionary")
For Each it In Array("Banana", "Apple", "Orange", "Tomato", "Apple", "Lemon", "Lime", "Lime", "Apple")
c00 = .Item(it)
Next
sn = .keys ' the array .keys contains all unique keys
MsgBox Join(.keys, vbLf) ' you can join the array into a string
End With
End Sub[/vba]
This is the best, simplest method of all.Quote:
Originally Posted by snb
The trick is c00=.item(it). That line references the key in the dictionary, and does so for each value in your list. Of course, none of the keys exist in the dictionary at first. But, simply referencing a key in a dictionary CREATES that key. Referencing the same key again (when dupes are encountered) does not create the key again, because the key already exists in the dictionary.
The line could also be X=.item(it). Not sure why the poster used c00, that's sort of confusing.
.keys of a Dictionary object returns the list of keys.
Awesome solution, thx!
I wonder if there are other data structures which automatically create entries if a non-existent key is referenced?
Update:
The line could also be .item(it)=X. It does not matter which side of the assignment you reference the item in the dictionary.
this can also be done with a Collection. But, unlike the Dictionary object, there's no one-statement way to get all the keys in the Collection.
Code:...
On Error Resume Next
MyCollection.Add (value, cstr( value))
On Error GoTo 0
....
You could do something like this, without Collection or Dictionary Objects.
Code:Dim myArray As Variant, UniqueArray As Variant
Dim pointer As Long
Dim i As Long
myArray = Array("apple", "bat", "apple", "cat", "battery", "bat", "fish")
UniqueArray = myArray
pointer = LBound(UniqueArray) - 1
For i = LBound(UniqueArray) To UBound(UniqueArray)
If pointer < Application.Match(UniqueArray(i), UniqueArray, 0) - (1 - LBound(UniqueArray)) Then
pointer = pointer + 1
UniqueArray(pointer) = UniqueArray(i)
End If
Next i
ReDim Preserve myArray(LBound(UniqueArray) To pointer)
MsgBox Join(UniqueArray)
It does matter.Quote:
Update:
The line could also be .item(it)=X. It does not matter which side of the assignment you reference the item in the dictionary.
In the case x=.item(it) or c00=.item(it) the item is empty, and the .items property of the dictionary doesn't return anything. So only the property .keys is available; and that is the purpose of the code exactly (and nothing more)
In the case .item=x the item isn't empty. The property .items will return an array although we don't need or use it for our purpose. So the .items array is redundant.
without collection/dictionary:
Code:sub M_snb()
For Each it In Array("Banana", "Apple", "Orange", "Tomato", "Apple", "Lemon", "Lime", "Lime", "Apple")
if instr(c00 & "|","|" & it & "|")=0 then c00=c00 & "|" & it
Next
unique_items=split(mid(c00,2),"|")
End Sub