Check whether value exists in collection or array, and if not, add it

Question

I want to add a list of items to a collection and avoid adding duplicates. Here's my list in Column A

Apple
Orange
Pear
Orange
Orange
Apple
Carrot

I only want to add

Apple 
Orange 
Pear 
Carrot

Here's what I came up with, and it works, but it's not pretty.

dim coll as New Collection

ln = Cells(Rows.Count, 1).End(xlUp).Row

coll.Add (Cells(1, 1).Value)   'Add first item manually to get it started
For i = 1 To ln

    addItem = True    'Assume it's going to be added until proven otherwise

    For j = 1 To coll.Count    'Loop through the collection

        'If we ever find the item in the collection
        If InStr(1, Cells(i, 1), coll(j), vbTextCompare) > 0 Then                     

            addItem = False     'set this bool false

        End If

    Next j

    If addItem = True Then   'It never got set to false, so add it

        coll.Add (Cells(i, "A").Value)

    End If

Next i

Is there a less convoluted way to do it? Preferably something like

If Not coll.Contains(someValue) Then
    coll.Add (someValue)
End If

Answer 1

I would strongly recommend using dictionaries, as they have a lot of features that collections do not, including Exists function.

With that said, it would be quite easy to create a function that first checks to see if a value exists within a collection, and then another function that will only add a value if it doesn't already exist.

Check if value exists

To see if it already exists, just use a simple for loop. If the value exists, return true and exit the function.

' Check to see if a value is in a collection.
' Functional approcah to mimic dicitonary `exists` method.
Public Function CollectionValueExists(ByRef target As Collection, value As Variant) As Boolean
    Dim index As Long
    For index = 1 To target.Count
        If target(index) = value Then
            CollectionValueExists = True
            Exit For
        End If
    Next index
End Function

Add unique values

Using the new function CollectionValueExists it is as simple as a if conditional statement to see if it should be added or not.

To make this even more dynamic, you could also use a ParamArray to allow multiple values to be added with one call. Simply loop each value and see if it needs to be added. This does not apply to your example, but is flexible for other uses.

' Adds unique values to a collection.
' @note this mutates the origianal collection.
Public Function CollectionAddUnique(ByRef target As Collection, ParamArray values() As Variant) As Boolean
    Dim index As Long
    For index = LBound(values) To UBound(values)
        If Not CollectionValueExists(target, values(index)) Then
            CollectionAddUnique = True
            target.Add values(index)
        End If
    Next index
End Function

Demo

Putting it all together, you can simply loop your range and call the new function.

Private Sub demoAddingUniqueValuesToCollection()
    Dim fruits As Collection
    Set fruits = New Collection
    
    Dim cell As Range
    For Each cell In Range("A1", Range("A" & Rows.Count).End(xlUp))
        CollectionAddUnique fruits, cell.value
    Next cell
End Sub

Answer 2

this will fill a collection of only unique:

Dim coll As New Collection
Dim ln As Long
ln = Cells(Rows.count, 1).End(xlUp).Row

Dim i As Long
For i = 1 To ln
    On Error Resume Next
        coll.Add Cells(i, 1).Value, Cells(i, 1).Value
    On Error GoTo 0
Next i

Dim ech
For Each ech In coll
    Debug.Print ech
Next ech

Answer 3

Here is mine

Option Explicit


Sub Test()

    Dim Ln
    Ln = Cells(Rows.Count, 1).End(xlUp).Row

    Dim rngInput As Excel.Range
    Set rngInput = Range(Cells(1, 1), Cells(Ln, 1)) '* really should qualify with a sheet otherwise you're at the mercy of activesheet

    Dim dicUnique As Scripting.Dictionary '* requires Tools->Reference : Microsoft Scripting Runtime
    Set dicUnique = UniqueCellContents(rngInput)

    Dim vOutput As Variant
    vOutput = dicUnique.Keys

    Dim rngOutput As Excel.Range
    Set rngOutput = Range(Cells(1, 3), Cells(dicUnique.Count, 3))  '* really should qualify with a sheet otherwise you're at the mercy of activesheet
    rngOutput.Value = Application.Transpose(vOutput)

'
'    Dim coll As New Collection
'
'    Ln = Cells(Rows.Count, 1).End(xlUp).Row
'
'    coll.Add (Cells(1, 1).Value)   'Add first item manually to get it started
'    For i = 1 To Ln
'
'        AddItem = True    'Assume it's going to be added until proven otherwise
'
'        For j = 1 To coll.Count    'Loop through the collection
'
'            'If we ever find the item in the collection
'            If InStr(1, Cells(i, 1), coll(j), vbTextCompare) > 0 Then
'
'                AddItem = False     'set this bool false
'
'            End If
'
'        Next j
'
'        If AddItem = True Then   'It never got set to false, so add it
'
'            coll.Add (Cells(i, "A").Value)
'
'        End If
'
'    Next i

End Sub

Function UniqueCellContents(ByVal rngInput As Excel.Range) As Scripting.Dictionary
    Dim dic As Scripting.Dictionary '* requires Tools->Reference : Microsoft Scripting Runtime
    Set dic = New Scripting.Dictionary

    Dim vValues As Variant
    vValues = (rngInput)

    If Not IsArray(vValues) Then
        dic.Add vValues, 0
    Else
        Dim vLoop As Variant
        For Each vLoop In vValues
            If Not dic.Exists(vLoop) Then
                dic.Add vLoop, 0
            End If

        Next vLoop

    End If

    Set UniqueCellContents = dic

End Function

Answer 4

Another method is to use a Scripting Dictionary. This does have an Exists method - the code below actually bypasses this and will overwrite an existing item if the key already exists.

Sub x()

Dim oDic As Object, r As Range

Set oDic = CreateObject("Scripting.Dictionary")

For Each r In Range("A1:A7")
    oDic(r.Value) = r.Row
    ' if not odic.exists(r.value) then ...
Next r

MsgBox Join(oDic.keys, ",")

End Sub

Answer 5

If you want to check for the existence of an item in a collection (as they don't have the exist functionality of dictionaries) then I use the following snippet

Public Function InCollection(Col As Collection, key As String) As Boolean
  Dim var As Variant
  Dim errNumber As Long

  InCollection = False
  Set var = Nothing

  Err.clear
  On Error Resume Next
    var = Col.Item(key)
    errNumber = CLng(Err.Number)
  On Error GoTo 0

  '5 is not in, 0 and 438 represent incollection
  If errNumber = 5 Then ' it is 5 if not in collection
    InCollection = False
  Else
    InCollection = True
  End If

End Function

Used such as:

If InCollection(CollectionName,IDKey) Then

Else

End If

Answer 6

Another way

Dim coll As New Collection
Dim i As Long

For i = 1 To Cells(Rows.count, 1).End(xlUp).Row
    If Worksheetfunction.CountIf(Cells(1,1).Resize(i), Cells(i, 1).Value) = 1 Then coll.Add Cells(i, 1).Value, Cells(i, 1).Value
Next

Or

Dim coll As New Collection
Dim oldValues As Variant
Dim cell As Range

With Range(Cells(1, 1), Cells(Rows.count, 1).End(xlUp))
    oldValues = .Value
    .RemoveDuplicates Columns:=1, Header:=xlNo
    For Each cell In .SpecialCells(xlCellTypeConstants)
        coll.Add cell.Value, cell.Value
    Next
    .Value = oldValues
End With