Activex Controls Combo Box unique values

[Jenst]

Hi! The code below is populating a combo box (activex controls), but after running the code I have a lot of multiple values in the dropdown menu. Is there a way manually or with vba to tell excel to input only unique values? Many thanks for your effort! Jens

Part of my code:

Sheets("Task").Select
i = Range("I3", Range("I3").End(xlDown)).Count
i = i + 2
Sheets("Overview Chart").Select
ActiveSheet.Shapes.Range(Array("ComboBox1")).Select


With Selection
.ListFillRange = "Task!I3:I" & i
.LinkedCell = "Task!A1"
End With

Range("Z13:AA37").ClearContents

[Kenneth Hobs]

See if this gives you any ideas.

' Sort ascending, remove duplicates, remove blanks, fill control's list.
Sub RangeUniqueSortFillControl(aRange As Range, aControl As Object)
Dim a() As Variant, b As Variant
a() = RangeTo1dArray(aRange)
b = UniqueArrayByDict(a(), tfStripBlanks:=True)
a() = ArrayListSort(b, True)
aControl.List = a()
End Sub


' http://www.excelforum.com/excel-programming-vba-macros/819998-filter-and-sort-scripting-dictionary.html
' Early Binding method requires Reference: MicroSoft Scripting Runtime, scrrun.dll
Function UniqueArrayByDict(Array1d() As Variant, Optional compareMethod As Integer = 0, _
Optional tfStripBlanks = False) As Variant
'Dim dic As Object 'Late Binding method - Requires no Reference
'Set dic = CreateObject("Scripting.Dictionary") 'Late or Early Binding method
Dim dic As Dictionary 'Early Binding method
Set dic = New Dictionary 'Early Binding Method
Dim e As Variant
dic.CompareMode = compareMethod
'BinaryCompare=0
'TextCompare=1
'DatabaseCompare=2
For Each e In Array1d
If Not dic.Exists(e) Then
If tfStripBlanks And e <> "" Then dic.Add e, Nothing
End If
Next e
UniqueArrayByDict = dic.Keys
End Function


Function RangeTo1dArray(aRange As Range) As Variant
Dim a() As Variant, c As Range, i As Long
ReDim a(0 To aRange.Cells.Count - 1)
i = i - 1
For Each c In aRange
i = i + 1
a(i) = c
Next c
RangeTo1dArray = a()
End Function


'http://www.vbaexpress.com/forum/showthread.php?48491
Function ArrayListSort(sn As Variant, Optional bAscending As Boolean = True)
With CreateObject("System.Collections.ArrayList")
Dim cl As Variant
For Each cl In sn
.Add cl
Next

.Sort 'Sort ascendending
If bAscending = False Then .Reverse 'Sort and then Reverse to sort descending
ArrayListSort = .Toarray()
End With
End Function

[Jenst]

The code below looks like a shortcut to what I want to achieve. But still I have trouble implementing it, because I don't know how to get the code running.
1) Sub RangeUniqueSortFillControl(aRange As Range, aControl As Object) what should this expression tell me? If I put something in the () after my sub, it will produce an error.

2) RangeTo1dArray(aRange) , b = UniqueArrayByDict
I get an error on this lines of codes. Do I have to activate a special dictionary, collection??




Sub RangeUniqueSortFillControl(aRange As Range, aControl As Object)
Dim a() As Variant, b As Variant
a() = RangeTo1dArray(aRange)
b = UniqueArrayByDict(a(), tfStripBlanks:=True)
a() = ArrayListSort(b, True)
aControl.List = a()
End Sub

[Kenneth Hobs]

It can be a simple one line call. I broke it down to be easier for you to see.

Private Sub ComboBox1_Click()
Dim r As Range, s As Object
Set r = Worksheets("Task").Range("I3", Worksheets("Task").Range("I3").End(xlDown))
Set s = Worksheets("Overview Chart").OLEObjects("ComboBox1").Object
RangeUniqueSortFillControl r, s
End Sub

[ZVI]

Try this:


Sub MyMacro()
Dim Rng As Range
With Sheets("Task")
Set Rng = .Range("I3", .Cells(.Rows.Count, "I").End(xlUp))
End With
With Sheets("Overview Chart").ComboBox1
.ListFillRange = ""
.List = UniqSort(Rng)
.LinkedCell = "Task!A1"
End With
End Sub

Function UniqSort(Rng As Range) As Variant()
Dim sKey As String, vArr, v
vArr = Intersect(Rng.Parent.UsedRange, Rng).Value
With CreateObject("Scripting.Dictionary")
.CompareMode = 1
For Each v In vArr
sKey = Trim(v)
If Len(sKey) Then .Item(sKey) = 0
Next
vArr = .Keys
End With
With CreateObject("System.Collections.ArrayList")
For Each v In vArr
.Add v
Next
.Sort
UniqSort = .ToArray
End With
End Function