如何将Sheet4指定列中不在ListBox1的内容导入ListBox2？

原代码的核心问题 #

原代码逻辑完全偏离需求：它对ListBox1中每个选中项，遍历B列时只要单元格值不等于当前选中项就添加到ListBox2。这会导致同一个B列值被重复添加多次（比如某值不在所有选中项里，会被每个选中项的循环都添加一次），根本没实现「筛选出不在ListBox1所有选中项集合里的B列内容」的目标。

修复后的代码 #

Private Sub ListBox2_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
    Dim selectedItems As Object
    Dim lastRow As Long
    Dim cell As Range
    Dim cellValue As Variant
    
    ' 初始化字典，用于快速查找ListBox1选中项
    Set selectedItems = CreateObject("Scripting.Dictionary")
    
    ' 清空ListBox2
    Me.ListBox2.Clear
    
    ' 把ListBox1所有选中项存入字典
    For X = 0 To ListBox1.ListCount - 1
        If Me.ListBox1.Selected(X) = True Then
            cellValue = Me.ListBox1.List(X)
            ' 避免字典中存入重复项
            If Not selectedItems.Exists(cellValue) Then
                selectedItems.Add cellValue, True
            End If
        End If
    Next X
    
    ' 获取Sheet4 B列有效数据的最后一行，且限制在B500以内
    lastRow = Sheet4.Cells(Sheet4.Rows.Count, "B").End(xlUp).Row
    If lastRow > 500 Then lastRow = 500
    
    ' 遍历B2到B500的单元格，筛选不在选中项里的内容
    For Each cell In Sheet4.Range("B2:B" & lastRow)
        cellValue = cell.Value
        ' 跳过空单元格，且值不在选中项集合中时添加到ListBox2
        If cellValue <> "" And Not selectedItems.Exists(cellValue) Then
            With Me.ListBox2
                .AddItem cellValue
                .Font.Size = 8
            End With
        End If
    Next cell
    
    ' 释放对象
    Set selectedItems = Nothing
End Sub

关键改进点 #

• 使用Scripting.Dictionary存储选中项，实现快速查找，比循环比对效率高得多
• 先统一收集所有选中项，再一次性遍历B列判断，彻底避免重复添加问题
• 动态获取B列有效行，同时严格限制在B2:B500范围内，不遍历无效空行
• 自动跳过空单元格，避免ListBox2出现无效空项

内容的提问来源于stack exchange，提问作者Lakshmi Ss