在一列中查找唯一值并使用 VBA 代码将它们连接到一个单元格中（删除开头和结尾的空白以避免重复）

Question

我正在测试此功能以找到列的唯一值并将其显示在逗号分隔的单元格中。通过以下功能，它可以执行我想要的，但是当开头或结尾处有空白时，它会返回由这些空白引起的重复值。

这是功能：

Function ConcatUniq(xRg As Range, xChar As String) As String
'updateby Extendoffice
    Dim xCell As Range
    Dim xDic As Object
    Set xDic = CreateObject("Scripting.Dictionary")
    For Each xCell In xRg
        xDic(xCell.Value) = Empty
    Next
    ConcatUniq = Join$(xDic.Keys, xChar)
    Set xDic = Nothing
End Function

非常感谢！

Answer 1

将唯一值连接到字符串 (UDF)

Function ConcatUniq( _
     ByVal xRg As Range, _
     Optional ByVal xChar As String = ", ") _
As String
    
    ' Write the values from the range to an array.
    
    Dim rCount As Long: rCount = xRg.Rows.Count
    Dim cCount As Long: cCount = xRg.Columns.Count
    
    If rCount + cCount = 2 Then ' one cell
        ReDim Data(1 To 1, 1 To 1): Data(1, 1) = xRg.Value
    Else ' multiple cells
        Data = xRg.Value
    End If
        
    ' Write the unique values from the array to the keys of a dictionary.
        
    Dim xDic As Object: Set xDic = CreateObject("Scripting.Dictionary")
    xDic.CompareMode = vbTextCompare ' case-insensitive i.e. 'A=a'
        
    Dim Key As Variant
    Dim r As Long, c As Long
    
    For r = 1 To rCount
        For c = 1 To cCount
            Key = Data(r, c)
            If Not IsError(Key) Then ' exclude error values
                If Len(Key) > 0 Then ' exclude blanks
                    xDic(Application.Trim(Key)) = Empty ' trim
                End If
            End If
        Next c
    Next r
    
    If xDic.Count = 0 Then Exit Function ' only error values or blanks
    
    ' Concatenate the unique values from the keys of the dictionary to a string.

    ConcatUniq = Join(xDic.Keys, xChar)
    
End Function