VBA合并多源数据到ComboBox列表并去重问题求助

你的代码存在几个导致去重失效的核心问题：

1. 拼接字符串时未处理空单元格，Split后会生成空数组元素，Unique函数不会自动过滤这些空值
2. 未去除单元格值的前后空格，导致类似"供应商A"和" 供应商A"的内容被判定为不同值
3. WorksheetFunction.Unique返回的是二维数组，直接赋值给ComboBox.List可能引发逻辑异常

下面提供三种针对性的解决方法：

方案1：改进原有字符串拼接逻辑 #

修正拼接时的判断逻辑，跳过空值并去除内容前后空格，最后将二维去重数组转为一维数组：

Sub Combo()
    Dim rng1 As Range, rng2 As Range
    Dim cl As Range
    Dim arStr As String
    Dim uniqueArr As Variant
    Dim oneDimArr() As String
    Dim i As Integer
    
    Set rng1 = sheet14.Range("Range_1")
    Set rng2 = sheet14.Range("Range_2")
    
    ' 遍历第一个区域，跳过空值并去除前后空格
    For Each cl In rng1
        If Trim(cl.Value) <> "" Then
            arStr = IIf(arStr = "", Trim(cl.Value), arStr & "," & Trim(cl.Value))
        End If
    Next cl
    
    ' 遍历第二个区域，执行相同处理
    For Each cl In rng2
        If Trim(cl.Value) <> "" Then
            arStr = IIf(arStr = "", Trim(cl.Value), arStr & "," & Trim(cl.Value))
        End If
    Next cl
    
    ' 拆分字符串、去重并转换为一维数组
    If arStr <> "" Then
        uniqueArr = WorksheetFunction.Unique(Split(arStr, ","))
        ReDim oneDimArr(UBound(uniqueArr) - 1)
        For i = 0 To UBound(uniqueArr) - 1
            oneDimArr(i) = uniqueArr(i + 1, 1)
        Next i
        sheet13.SupplierCmb.List = oneDimArr
    Else
        sheet13.SupplierCmb.Clear
    End If
End Sub

方案2：直接合并区域去重（更高效） #

跳过字符串拼接步骤，直接合并两个区域后去重，避免字符串处理带来的问题：

Sub Combo_Improved()
    Dim rng1 As Range, rng2 As Range
    Dim combinedRng As Range
    Dim uniqueArr As Variant
    Dim oneDimArr() As String
    Dim i As Integer
    
    Set rng1 = sheet14.Range("Range_1")
    Set rng2 = sheet14.Range("Range_2")
    
    ' 合并两个目标区域
    Set combinedRng = Union(rng1, rng2)
    
    ' 去重并过滤空值
    uniqueArr = WorksheetFunction.Unique(combinedRng)
    uniqueArr = Filter(uniqueArr, "", False)
    
    ' 转换为一维数组并去除空格
    ReDim oneDimArr(UBound(uniqueArr))
    For i = 0 To UBound(uniqueArr)
        oneDimArr(i) = Trim(uniqueArr(i))
    Next i
    
    ' 赋值给ComboBox
    sheet13.SupplierCmb.List = oneDimArr
End Sub

方案3：兼容旧版Excel（无Unique函数） #

如果你的Excel版本低于2021或没有365订阅，Unique函数不可用，可使用字典对象手动去重：

Sub Combo_Legacy()
    Dim rng1 As Range, rng2 As Range
    Dim cl As Range
    Dim dict As Object
    Dim oneDimArr() As String
    Dim i As Integer
    
    Set dict = CreateObject("Scripting.Dictionary")
    Set rng1 = sheet14.Range("Range_1")
    Set rng2 = sheet14.Range("Range_2")
    
    ' 遍历区域，利用字典键的唯一性自动去重
    For Each cl In rng1
        If Trim(cl.Value) <> "" Then dict(Trim(cl.Value)) = ""
    Next cl
    For Each cl In rng2
        If Trim(cl.Value) <> "" Then dict(Trim(cl.Value)) = ""
    Next cl
    
    ' 将字典键转换为一维数组并赋值
    If dict.Count > 0 Then
        ReDim oneDimArr(dict.Count - 1)
        i = 0
        For Each Key In dict.Keys
            oneDimArr(i) = Key
            i = i + 1
        Next Key
        sheet13.SupplierCmb.List = oneDimArr
    Else
        sheet13.SupplierCmb.Clear
    End If
End Sub

注意：确保sheet14和sheet13是正确的工作表代码名，若使用工作表名称需改为ThisWorkbook.Worksheets("工作表名")格式。

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