Want to stop my concatenate function concatenating duplicates

**bm1** · 04-14-2010, 11:25 AM

I am using a custom function to concatenate a range of cells, but want to modify it so it won't concatenate any duplicated values

any help much appreciated

here is the function I'm using

Function Concat(myRange As Range)
    
    Dim r As Range
    myDelimiter = "+"
    Application.Volatile
    For Each r In myRange
        If r <> "" Then
            Concatenate = Concatenate & r & myDelimiter
        End If
        
    Next r
    If Len(myDelimiter) > 0 Then
       Concat = Left(Concatenate, Len(Concatenate) - Len(myDelimiter))
    End If

End Function

**mdbct** · 04-14-2010, 03:59 PM

The Option Base 1 goes with the Option Explicit at the top of the module. If Option Explicit does not exist - add it.

I suggest turning the "Require Variable Declaration" option on full time. In the VBA area, go to Tools / Options... Editor tab and check the "Require Variable Declaration" box.

Option Base 1

Function Concat(myRange As Range) As String
    Dim myDelimiter As String
    Dim r As Range
    myDelimiter = "+"
    Application.Volatile
    Dim i As Integer, x As Integer
    Dim j() As String, exists As Boolean
    ReDim j(1)
    For Each r In myRange
        If r <> "" Then
            For x = 1 To UBound(j)
                If j(x) = r Then
                    exists = True
                    Exit For
                Else
                    exists = False
                End If
            Next x
            If exists = False Then
                i = i + 1
                ReDim Preserve j(i)
                j(i) = r
            End If
        End If
    Next r
      Concat = Join(j, myDelimiter)
End Function

**shg** · 04-14-2010, 04:14 PM

Here's another way:

Option Explicit

#Const EarlyBound = False

Function CatUnique(r As Range, Optional sSep As String = ",") As String
    CatUnique = Join(Unique(r), sSep)
End Function

Function Unique(r As Range, Optional bCount As Boolean = False) As Variant
    ' Returns an array containing the unique values in r
    
    Dim cell        As Range

#If EarlyBound Then
    ' Requires a reference to Microsoft Scripting Runtime
    With New Scripting.Dictionary
#Else
    ' No reference required
    With CreateObject("Scripting.Dictionary")
#End If

        For Each cell In r
            If Not (.Exists(cell.Value) Or IsEmpty(cell.Value)) Then
                .Add Key:=cell.Value, Item:=vbNullString
            End If
        Next cell
    
        If bCount Then Unique = .Count Else Unique = .Keys
    End With
End Function

E.g., =CatUnique(A1:A10, "+")