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

user_18748812 0
Viewed 211

I am testing this function to find unique values of a column and display them in a cell separated by commas. With the following function it does what I want, but when there are blanks at the beginning or at the end, it returns duplicate values caused by these blanks.

This is the function:

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

Thank you very much!

excel-formula vba excel function
1 Answers

Concatenate Unique Values to a String (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
user_98140690
Related