Dom,
Thanks for the quick reply. Looks like this will work, but I have one further question. Where would I integrate this function? To be honest, I'm pretty green when it comes to VBA. I added the code from your link, and integrated the relevant parts to my macro, but I get the error "type mismatch". Here's what I have thus far.
Private Sub UserForm_Initialize()
Dim a, i As Long, w()
Dim NoDupes As New Collection
Dim T As Integer, j As Integer
Dim Swap1, Swap2, Item
With Sheets("Holdings For Export")
a = .Range("D4103", .Range("d" & Rows.Count).End(xlUp)).Resize(, 25).Value
End With
Set dic = CreateObject("Scripting.Dictionary")
dic.CompareMode = 1
For i = 2 To UBound(a, 1)
If Not dic.exists(a(i, 1)) Then dic.Item(a(i, 1)) = Empty
If IsEmpty(dic.Item(a(i, 1))) Then
ReDim w(0)
Else
w = dic.Item(a(i, 1))
ReDim Preserve w(UBound(w) + 1)
End If
w(UBound(w)) = a(i, 25)
dic.Item(a(i, 1)) = w
Next
Dim AllCells As Range, Cell As Range
' The items are in A1:A105
Set AllCells = dic
' The next statement ignores the error caused
' by attempting to add a duplicate key to the collection.
' The duplicate is not added - which is just what we want!
On Error Resume Next
For Each Cell In AllCells
NoDupes.Add Cell.Value, CStr(Cell.Value)
' Note: the 2nd argument (key) for the Add method must be a string
Next Cell
' Resume normal error handling
On Error GoTo 0
' Sort the collection (optional)
For T = 1 To NoDupes.Count - 1
For j = T + 1 To NoDupes.Count
If NoDupes(T) > NoDupes(j) Then
Swap1 = NoDupes(T)
Swap2 = NoDupes(j)
NoDupes.Add Swap1, before:=j
NoDupes.Add Swap2, before:=T
NoDupes.Remove T + 1
NoDupes.Remove j + 1
End If
Next j
Next T
Me.ManagerSellEntity.list = dic.keys
End Sub
Bookmarks