来自列表框列/字段的组合框列表中的VBA唯一值答案

【问题标题】：VBA Unique values in Combobox list from Listbox column / field来自列表框列/字段的组合框列表中的VBA唯一值
【发布时间】：2021-03-18 14:45:15
【问题描述】：

每次列表框的列表更改时，我都希望仅在列表框字段/列中创建一个组合框列表。

例如，列表框中的第 3 列包含 Apple、Strawberry 和 Banana 的多个实例。我希望组合框每个只包含一次 Apple、Strawberry 和 Banana。

有什么优雅的想法吗？

【问题讨论】：

标签： excel vba combobox listbox unique

【解决方案1】：

可以使用字典从列表中删除重复项。要使以下代码正常工作，您必须将“Microsoft Scripting Runtime”添加到您的references。

Private Sub ListBox1_Change()
    Dim dict As Scripting.Dictionary
    Set dict = New Scripting.Dictionary
    Dim i As Long
    On Error Resume Next
    For i = 0 To ListBox1.ListCount - 1
        dict.Add Key:=ListBox1.List(i), Item:=0
    Next i
    ComboBox1.List = dict.Keys
End Sub

我还没有机会测试它，让我知道它是否有效。

【讨论】：

这非常有效，谢谢。我只是将 ListBox1.List(i) 更改为 ListBox1.List(i,3) 以仅选择要添加的一列。

【解决方案2】：

试试下面的代码，让我们知道您的反馈。

Private Sub ListBox1_Change()
    Dim dict As Object
    Dim i As Long

    Set dict = CreateObject("Scripting.Dictionary")
        For i = 0 To ListBox1.ListCount - 1
            dict.Item(ListBox1.List(i)) = vbNullString
        Next i
    ComboBox1.List = dict.keys
    Set dict = Nothing
End Sub

【讨论】：

谢谢。我选择了第一个答案。这个非常相似。感谢您的贡献。
没问题。是的，几乎相似，但很棒的是无需添加任何参考。

【解决方案3】：

将唯一的第 3 列项分配给组合框

[1]接收uniques有几种方式（字典、数组列表）；我演示了一种使用FilterXML() 函数的方法（自 2013+ 版本起可用）以及通过arr = Application.Index(Me.ListBox1.Column, 3, 0) 的列表框.Column 属性隔离第三个列表框列 的棘手方法，从而接收一个没有循环的“平面”数组，
[2] 基于数组数据创建一个简单的格式良好的 xml 结构，并提供一个 XPath 搜索字符串来获取唯一性和
[3] 将通过FilterXML() 接收到的“垂直”二维唯一值分配给组合框.List 属性。此外，我添加了一个小错误处理程序，用于处理单个项目的情况。

Private Sub ListBox1_Change()
    If Me.ListBox1.ListCount = 0 Then Exit Sub              ' Escape if no list items available
    With Application
        '[1] get 3rd column items of listbox
        Dim arr: arr = .Index(Me.ListBox1.Column, 3, 0)     ' Index uses 1-based indices

        '[2] create FilterXML arguments to get uniques
        Dim XContent As String: XContent = "<t><s>" & Join(arr, "</s><s>") & "</s></t>"
        Dim XP As String: XP = "//s[not(preceding::*=.)]"   ' XPath expression searching uniques
        '[3] assign "vertical" 2-dim uniques to combobox
        Dim uniques: uniques = .FilterXML(XContent, XP)     ' get uniques to combobox
        On Error Resume Next:  Me.ComboBox1.List = uniques  ' assign uniques to combobox
        If Err.Number <> 0 Then Me.ComboBox1.AddItem uniques
    End With
End Sub

【讨论】：

感谢您的贡献。这是一个经过深思熟虑的解决方案。