求助编写实现去重拼接的VBA自定义函数ConcatenateUnique

原代码问题分析 #

你的代码存在两个关键问题：

1. 判断逻辑错误：用CountIf(Ref, Cell.Value) <=1会直接排除所有出现多次的内容（比如示例中的"One"），而需求是重复内容只保留一次，而非完全排除。
2. 函数名不匹配：最后将结果赋值给CONCATENATEMULTIPLE，但函数定义的名称是CONCATENATEUNIQUE，会导致返回值异常。

正确实现代码 #

使用VBA的Dictionary对象（利用其键的唯一性实现去重），代码如下：

Function ConcatenateUnique(Ref As Range, Separator As String) As String
    Dim cell As Range
    Dim uniqueDict As Object
    Dim resultStr As String
    
    ' 创建字典对象（后期绑定，无需额外引用）
    Set uniqueDict = CreateObject("Scripting.Dictionary")
    
    ' 遍历区域内的每个单元格
    For Each cell In Ref
        ' 跳过空单元格（可选，根据需求调整）
        If cell.Value <> "" Then
            ' 如果字典中没有当前值，则添加并拼接
            If Not uniqueDict.Exists(cell.Value) Then
                uniqueDict.Add cell.Value, cell.Value
                resultStr = resultStr & cell.Value & Separator
            End If
        End If
    Next cell
    
    ' 去掉末尾多余的分隔符（如果结果非空）
    If resultStr <> "" Then
        ConcatenateUnique = Left(resultStr, Len(resultStr) - Len(Separator))
    Else
        ConcatenateUnique = ""
    End If
    
    ' 释放对象
    Set uniqueDict = Nothing
End Function

代码说明 #

• Dictionary去重：通过判断值是否已存在于字典的键中，确保每个值仅被添加一次。
• 空单元格处理：跳过空单元格，避免拼接结果中出现多余的分隔符。
• 分隔符兼容：支持任意分隔符（如逗号、空格、分号等），通过参数传入。
• 错误处理：当区域全为空时，返回空字符串，避免运行时错误。

使用示例 #

对于你提供的数据集：

在单元格中输入=ConcatenateUnique(A1:B2, ",")，将返回One,Two,Three。

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