Getting Unique elements of Array

[darkmatter14]

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

[mdmackillop]

Welcome to VBAX.

Look up the Dictionary Object or Collection in VBA help. If you need more assistance, please ask.

[GTO]

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:

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

Hope this helps,

Mark

[mdmackillop]

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

[GTO]

@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

[mdmackillop]

It's very useful. Note that the Key has to be a string, so with numbers

aFirstArray() = Array(12, 5, 8, 6, 4, 8)
On Error Resume Next
For Each a In aFirstArray
    arr.Add a, Str(a)
Next

[GTO]

Thanks again brother, 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...")

[Kenneth Hobs]

Here is a dictionary method. Be sure to set the reference. I removed all empty elements as well.

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

[Brodon]

Not sure about this.Please explaine me………..

[Aussiebear]

Did you try the code?

[snb]

or simply

 
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

[johnywhy]

or simply

 
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

This is the best, simplest method of all.

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.

...
On Error Resume Next
MyCollection.Add (value, cstr( value))
On Error GoTo 0
....

[mikerickson]

You could do something like this, without Collection or Dictionary Objects.

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)

[snb]

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.

It does matter.

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:

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