CODEWITHSUNDEEP
excelvbacombobox
Alexander Paudak
Alexander Paudak

Reputation: 155

How uniquely populate vba combobox from excel?

Consider this list from excel:

enter image description here

How can I add this on my user form Combobox without repetition of each item? I made this one cmboDepartment.List = Sheets("DB").Range("A3:A995").Value but it takes all the list.

Upvotes: 0

Views: 38

Answers (2)

VBasic2008
VBasic2008

Reputation: 54983

Dictionary vs ArrayList

  • Note that the ArrayList needs .Net FrameWork 3.5 (even if you have newer ones installed) which is over 200MB in size.
Option Explicit

Sub copyUniqueToCombo()
    Dim ws As Worksheet: Set ws = ThisWorkbook.Worksheets("DB")
    Dim Data As Variant
    Data = ThisWorkbook.Worksheets("DB").Range("A3:A995").Value
    With CreateObject("Scripting.Dictionary")
        .CompareMode = vbTextCompare
        Dim cValue As Variant
        Dim i As Long
        For i = 1 To UBound(Data, 1)
            cValue = Data(i, 1)
            If Not IsError(cValue) Then
                If Len(cValue) > 0 Then
                    .Item(cValue) = Empty
                End If
            End If
        Next i
        cmboDepartment.List = .Keys
    End With
End Sub

Sub copyUniqueToComboSorted()
    Dim ws As Worksheet: Set ws = ThisWorkbook.Worksheets("DB")
    Dim Data As Variant
    Data = ThisWorkbook.Worksheets("DB").Range("A3:A995").Value
    With CreateObject("System.Collections.ArrayList")
        Dim cValue As Variant
        Dim i As Long
        For i = 1 To UBound(Data, 1)
            cValue = Data(i, 1)
            If Not IsError(cValue) Then
                If Len(cValue) > 0 Then
                    'cValue = CStr(cValue)
                    If Not .Contains(cValue) Then
                        .Add cValue
                    End If
                End If
            End If
        Next i
        .Sort ' All the values have to be of the same type e.g. String
        cmboDepartment.List = .ToArray
    End With
End Sub

Upvotes: 1

Harun24hr
Harun24hr

Reputation: 37125

First put below sub to a standard module. Adjust sheet names for your workbook.

Public Sub CopyUniqueOnly()
Dim i As Long

    Dim currCell As Range, dict As Object
    Set dict = CreateObject("Scripting.Dictionary")

    With ThisWorkbook.Worksheets("db") 'Change your sheet name.
        For Each currCell In .Range("A1", .Cells(.Rows.Count, 1).End(xlUp))
            If Not dict.exists(currCell.Value) And Not IsEmpty(currCell) Then
                dict.Add currCell.Value, currCell.Value
            End If
        Next currCell
    End With
    
 Sheets("DB").Range("ZZ1").Resize(dict.Count) = Application.Transpose(dict.keys)
    
End Sub

Then put below codes to form Initialize event.

Private Sub UserForm_Initialize()
    Call CopyUniqueOnly
    cmboDepartment.List = Sheets("DB").Range("zz1").CurrentRegion.Value
    Sheets("DB").Range("zz1").CurrentRegion.Clear
End Sub

Upvotes: 0

Related Questions