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

Question

我正在测试此功能以查找列的唯一值并将它们显示在以逗号分隔的单元格中。使用以下函数，它可以满足我的要求，但是当开头或结尾有空白时，它 returns 由这些空白引起的重复值。

这是函数：

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

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

Find Unique Values In A Column And Concatenate Them Into One Cell With VBA Code (deleting blanks from start and end to avoid duplicates)

excel

vba

function

excel-formula

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