Extract unique values from Column D and combine in a single cell. Excel VBA

Question

I have duplicate values in column (D).

How to Extract unique values from Column D and combine in a single cell (H1) without losing data by using vba

for example: "J10P, G345, R1, J10G"

Answer 1

Concatenate Unique Values (Dictionary)

• Adjust the values in the constants section and the workbook.

Option Explicit

Sub concatUnique()
    
    Const sName As String = "Sheet1"
    Const sFirst As String = "D1"
    
    Const dName As String = "Sheet1"
    Const dFirst As String = "H1"
    Const dDelim As String = ", "

    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    ' Create a reference to the Source Range.
    Dim srg As Range
    Dim srCount As Long
    With wb.Worksheets(sName).Range(sFirst)
        Dim lCell As Range
        Set lCell = .Resize(.Worksheet.Rows.Count - .Row + 1) _
            .Find("*", , xlFormulas, , , xlPrevious)
        If lCell Is Nothing Then Exit Sub
        srCount = lCell.Row - .Row + 1
        Set srg = .Resize(srCount)
    End With

    ' Write values from Source Range to Source Data Array.
    Dim sData As Variant
    If srCount = 1 Then
        ReDim sData(1 To 1, 1 To 1): sData(1, 1) = srg.Value
    Else
        sData = srg.Value
    End If
    
    ' Write unique values from Source Data Array to Unique Dictionary.
    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    dict.CompareMode = vbTextCompare
    Dim Key As Variant
    Dim r As Long
    For r = 1 To UBound(sData, 1)
        Key = sData(r, 1)
        If Not IsError(Key) Then
            If Len(Key) > 0 Then
                dict(Key) = Empty
            End If
        End If
    Next r
    
    If dict.Count > 0 Then
        ' Create a reference to the Destination Cell (Range).
        Dim dCell As Range: Set dCell = wb.Worksheets(dName).Range(dFirst)
        ' Write the unique values from Unique Dictionary to Resulting String.
        Dim Result As String: Result = Join(dict.Keys, dDelim)
        ' Write the result to the Destination Cell (Range).
        dCell.Value = Result
        ' or in one line:
        'wb.Worksheets(dName).Range(dFirst).Value = Join(dict.Keys, dDelim)
    End If
    
End Sub