Remove Duplicates from a 1D array in VBA

[450nick]

I'm trying to take a list of data (1D array as variant containing lots of text inputs) and run this input array into a function which returns another array with a filtered list of maybe 8 unique entries from around 700+ in the input array. So far I have this, but I'm getting a type-mismatch error with the VBA filter - any ideas why?:

Function RemoveDupes(InputArray) As Variant


Dim Array_2()


Dim eleArr_1 As Variant
Dim x As Integer


x = 0
On Error Resume Next
For Each eleArr_1 In InputArray
If UBound(Filter(InputArray, eleArr_1)) = 0 Then
ReDim Preserve Array_2(x)
Array_2(x) = eleArr_1
x = x + 1
End If
Next
RemoveDupes = Array_2

End Function

 

[450nick]

Anyone?

 

[RickXL]

Hi,

It seems to be working for me.

Sub Test()
    Dim arr1, arr2
    arr1 = Array("aa2", "aa1", "aa3", "aa2", "aa3a", "aa3b")
    arr2 = RemoveDupes(arr1)
    Debug.Print Join(arr2, vbLf)
End Sub

Function RemoveDupes(InputArray) As Variant
    Dim Array_2()
    Dim eleArr_1 As Variant
    Dim x As Integer
    x = 0
    On Error Resume Next
    For Each eleArr_1 In InputArray
        If UBound(Filter(InputArray, eleArr_1)) = 0 Then
            ReDim Preserve Array_2(x)
            Array_2(x) = eleArr_1
            x = x + 1
        End If
    Next
    RemoveDupes = Array_2
End Function

What are you doing differently?

By the way, I am not sure what results you would expect from the above but I get:
aa1
aa3a
aa3b

Also, it can be counterproductive if you follow up your own posts because the standard search here returns all posts without replies. So if you reply to your own post it looks as if it might be answered and so it does not show up in the search results.

 

[Domenic]

If you're assigning a one dimensional array as per your previous thread, try assigning it as follows instead...

 With Application
    InputArray = .Transpose(.Index(your_array, 0, 4))
 End With

Hope this helps!

 

[450nick]

Perfect, thanks very much! I ended up modifying the code to something more useful - here it is:

Function RemoveDupes(InputArray) As Variant


Dim OutputArray As Variant
Dim CurrentValue As Variant
Dim A As Variant


On Error Resume Next
OutputArray = Array("")
For Each CurrentValue In InputArray
Flag = 0
If IsEmpty(CurrentValue) Then GoTo skip
For Each A In OutputArray
If A = CurrentValue Then
Flag = 1
Exit For
End If
Next A

If Flag = 0 Then
ReDim Preserve OutputArray(UBound(OutputArray, 1) + 1)
OutputArray(UBound(OutputArray, 1) - 1) = CurrentValue
End If


skip:
Next
RemoveDupes = OutputArray


End Function

 

[RickXL]

Anything to do with VBA and duplicates and I tend to think of Dictionaries.

If you use Windows you will have access to a Scripting Dictionary. This can hold a Key and an Item - a bit like a word and a definition in a "real" dictionary.
When used in a certain way the dictionary object will automatically create entries for new keys. If the same one happens again it will just overwrite it. This is a very simple way of getting a unique list.

If you used a dictionary then your function would become:

Function RemoveDupes(InputArray) As Variant
    Dim dic As Object
    Dim Key As Variant
    Set dic = CreateObject("Scripting.Dictionary")
    For Each Key In InputArray
        dic(Key) = 0
    Next
    RemoveDupes = dic.keys
End Function

The line

dic(Key) = 0

adds a new key which has a value equal to the value of the variable called key.
The Item in this case is not used so is set to 0.

The line

RemoveDupes = dic.keys

is a quick way to write all the keys from the dictionary to a variant.

If you don't use Windows then you can do something very similar, but needing a bit more code, with a Collection object.

 

[Rick Rothstein]

Here is another function you can try...

Function RemoveDupes(InputArray As Variant) As Variant
  Dim X As Long
  With CreateObject("Scripting.Dictionary")
    For X = LBound(InputArray) To UBound(InputArray)
      If Not IsMissing(InputArray(X)) Then .Item(InputArray(X)) = 1
    Next
    RemoveDupes = .Keys
  End With
End Function

 

[DEksel]

Here is another function you can try...

Function RemoveDupes(InputArray As Variant) As Variant
  Dim X As Long
  With CreateObject("Scripting.Dictionary")
    For X = LBound(InputArray) To UBound(InputArray)
      If Not IsMissing(InputArray(X)) Then .Item(InputArray(X)) = 1
    Next
    RemoveDupes = .Keys
  End With
End Function

So ellegant Rick, so ellegant and simple ofcourse. This thread should be refreshed because of internet search. Imho.

 

[450nick]

It seems I never replied to this but yes, Rick's solution is really elegant! I never cease to be amazed in the solutions that this forum can produce, always exceeding my wildest expectations. Thanks Rick & MrExcel

 

[rahulraji]

it giving error out of range