Excel（VBA） - UserForm组合框>列表框，停止重复

Upon selecting a category from a combobox a listbox then updates with only records related to the combobox selection. However the list is producing duplicates and I was wondering how I prevent this from happening.

在从组合框中选择类别时，列表框然后仅使用与组合框选择相关的记录进行更新。然而，该列表正在产生重复，我想知道如何防止这种情况发生。

Private Sub ProdComp_Change()
Dim RowMax As Integer
Dim ws As Worksheet
Dim countexit As Integer
Dim cellcombo2 As String
Dim i As Integer

Set ws = ThisWorkbook.Sheets("products")
RowMax = ws.Cells(Rows.Count, "B").End(xlUp).Row

Me.LBType.Clear

With LBType
    For i = 2 To RowMax
        If ws.Cells(i, "B").Value = ProdComp.Text Then
        .AddItem ws.Cells(i, "c").Value
        Else
        End If
    Next i
End With

End Sub

Worksheet View

工作表视图

UserForm View

UserForm视图

2 个解决方案

#1

You may give this a try...

你可以尝试一下......

Private Sub ProdComp_Change()
Dim RowMax As Integer
Dim ws As Worksheet
Dim countexit As Integer
Dim cellcombo2 As String
Dim i As Integer
Dim dict

Set ws = ThisWorkbook.Sheets("products")
RowMax = ws.Cells(Rows.Count, "B").End(xlUp).Row
Set dict = CreateObject("Scripting.Dictionary")

Me.LBType.Clear

With LBType
    For i = 2 To RowMax
        If ws.Cells(i, "B").Value = ProdComp.Text Then
            dict.Item(ws.Cells(i, "c").Value) = ""
        End If
    Next i
    If dict.Count > 0 Then .List = dict.keys
End With
End Sub

#2

Try adding the items to a unique collection and then add the collection to the listbox. This way you will not get any duplicates.

尝试将项目添加到唯一的集合，然后将该集合添加到列表框中。这样你就不会得到任何重复。

Try this

尝试这个

Private Sub ProdComp_Change()
    '~~> when working with Rows, Please do not use `Integer`. Use `Long`
    Dim RowMax As Long, countexit As Long, i As Long
    Dim ws As Worksheet
    Dim cellcombo2 As String
    Dim col As New Collection, itm As Variant

    Set ws = ThisWorkbook.Sheets("products")
    RowMax = ws.Cells(Rows.Count, "B").End(xlUp).Row

    For i = 2 To RowMax
        If ws.Cells(i, "B").Value = ProdComp.Text Then
            '~~> On error resume next will
            '~~> create a unique collection
            On Error Resume Next
            col.Add ws.Cells(i, "c").Value, CStr(ws.Cells(i, "c").Value)
            On Error GoTo 0
        End If
    Next i

    Me.LBType.Clear

    If col.Count > 0 Then
        For Each itm In col
            LBType.AddItem itm
        Next
    End If
End Sub

If you have too much of data then you can copy the data to the array instead of looping through rows and then create the unique collection.

如果您有太多数据，那么您可以将数据复制到数组而不是循环遍历行，然后创建唯一的集合。