Consulting

Results 1 to 14 of 14

Thread: Getting Unique elements of Array

  1. #1

    Getting Unique elements of Array

    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

  2. #2
    Administrator
    VP-Knowledge Base
    VBAX Grand Master mdmackillop's Avatar
    Joined
    May 2004
    Location
    Scotland
    Posts
    14,489
    Location
    Welcome to VBAX.

    Look up the Dictionary Object or Collection in VBA help. If you need more assistance, please ask.
    MVP (Excel 2008-2010)

    Post a workbook with sample data and layout if you want a quicker solution.


    To help indent your macros try Smart Indent

    Please remember to mark threads 'Solved'

  3. #3
    Knowledge Base Approver VBAX Guru GTO's Avatar
    Joined
    Sep 2008
    Posts
    3,368
    Location
    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

  4. #4
    Administrator
    VP-Knowledge Base VBAX Grand Master mdmackillop's Avatar
    Joined
    May 2004
    Location
    Scotland
    Posts
    14,489
    Location
    [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]
    MVP (Excel 2008-2010)

    Post a workbook with sample data and layout if you want a quicker solution.


    To help indent your macros try Smart Indent

    Please remember to mark threads 'Solved'

  5. #5
    Knowledge Base Approver VBAX Guru GTO's Avatar
    Joined
    Sep 2008
    Posts
    3,368
    Location
    @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

  6. #6
    Administrator
    VP-Knowledge Base VBAX Grand Master mdmackillop's Avatar
    Joined
    May 2004
    Location
    Scotland
    Posts
    14,489
    Location
    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]
    MVP (Excel 2008-2010)

    Post a workbook with sample data and layout if you want a quicker solution.


    To help indent your macros try Smart Indent

    Please remember to mark threads 'Solved'

  7. #7
    Knowledge Base Approver VBAX Guru GTO's Avatar
    Joined
    Sep 2008
    Posts
    3,368
    Location
    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...")

  8. #8
    VBAX Guru Kenneth Hobs's Avatar
    Joined
    Nov 2005
    Location
    Tecumseh, OK
    Posts
    4,956
    Location
    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]

  9. #9
    VBAX Newbie
    Joined
    Jul 2013
    Posts
    2
    Location
    Not sure about this.Please explaine me………..

  10. #10
    Moderator VBAX Guru Aussiebear's Avatar
    Joined
    Dec 2005
    Location
    Queensland
    Posts
    4,997
    Location
    Did you try the code?
    Remember To Do the Following....
    Use [Code].... [/Code] tags when posting code to the thread.
    Mark your thread as Solved if satisfied by using the Thread Tools options.
    If posting the same issue to another forum please show the link

  11. #11
    Knowledge Base Approver VBAX Wizard
    Joined
    Apr 2012
    Posts
    5,635
    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]

  12. #12
    Quote Originally Posted by snb View Post
    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.

    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
    ....
    Last edited by johnywhy; 12-24-2015 at 01:50 PM.

  13. #13
    Mac Moderator VBAX Guru mikerickson's Avatar
    Joined
    May 2007
    Location
    Davis CA
    Posts
    2,778
    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)

  14. #14
    Knowledge Base Approver VBAX Wizard
    Joined
    Apr 2012
    Posts
    5,635
    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

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •