Combine unique values from ranges (with condition) into another ranges

Combine Unique Values

Sub Extract_unique_values_and_combine_in_adjacent_cells()
    
    ' The delimiter between the 2nd column value and the 3rd column values.
    Const dDelimiter As String = vbLf ' use e.g. 'vbLf & vbLf' to understand
    ' The delimiter between the 3rd column values.
    Const vDelimiter As String = vbLf ' use e.g. ',' to understand
    
    ' Reference the worksheet ('ws').
    Dim ws As Worksheet: Set ws = ActiveSheet ' improve!
    
    ' Reference the table range (has headers).
    Dim strg As Range: Set strg = ws.Range("A1").CurrentRegion
    
    ' Calculate the number of data rows ('rCount')(exclude header row).
    Dim rCount As Long: rCount = strg.Rows.Count - 1
    
    ' Reference the source data range ('srg') (no headers).
    Dim srg As Range: Set srg = strg.Resize(rCount).Offset(1)
    
    ' Write the values from the source range to a 2D one-based array,
    ' the source array ('sData').
    Dim sData() As Variant: sData = srg.Value
    
    ' Reference a newly created dictionary object ('dict').
    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    dict.CompareMode = vbTextCompare ' case-insensitive i.e. 'a = A'
    
    ' The dictionary's 'keys' will hold the unique values from the 1st column,
    ' while each associated dictionary's 'item' will hold another dictionary
    ' whose 'keys' will hold the unique values from the 3rd column.
    
    Dim Key1 As Variant
    Dim Key3 As Variant
    Dim r As Long
    
    ' Loop through the rows of the source array...
    For r = 1 To rCount
        ' Write the current value from the 1st column to a variable ('Key1')...
        Key1 = sData(r, 1)
        ' ... and check if it isn't already a 'key' of the dictionary.
        If Not dict.Exists(Key1) Then ' not a 'key' in dictionary
            ' Add the value as the 'key' and assign a newly created dictionary
            ' to the associated item ('dict(Key1)').
            Set dict(Key1) = CreateObject("Scripting.Dictionary")
            dict(Key1).CompareMode = vbTextCompare ' case-insensitive
        'Else ' is a 'key' of the dictionary; do nothing
        End If
        ' Write the current value from the 3rd column to a variable ('Key3')...
        Key3 = sData(r, 3)
        If Not IsError(Key3) Then ' exclude errors
            If Len(CStr(Key3)) > 0 Then ' exclude blanks
                ' ... and add it to the 'keys' of the current 'item dictionary'.
                dict(Key1)(Key3) = Empty
            End If
        End If
    Next r
            
    ' Write the length of the 3rd column delimiter to a variable ('vLen')
    ' (to not calculate it over and over since it will be used in a loop).
    Dim vLen As Long: vLen = Len(vDelimiter)
    
    ' Concatenate the dictionary item dictionaries' keys to strings
    ' and replace the item dictionaries with those strings.
    
    Dim String3 As String
            
    ' Loop through the keys of the dictionary (dict.Keys)...
    For Each Key1 In dict.Keys
        ' Loop through the keys of the item dictionary ('dict(Key1).Keys')...
        For Each Key3 In dict(Key1).Keys
            ' ... and concatenate the values into a string ('String3').
            String3 = String3 & Key3 & vDelimiter
        Next Key3
        If Len(String3) > 0 Then ' the item dictionary was not empty
            ' Remove the redundant right most delimiter.
            String3 = Left(String3, Len(String3) - vLen)
        'Else ' the item dictionary was empty; do nothing
        End If
        ' Replace the item dictionary with the string.
        dict(Key1) = String3
        ' Reset the string variable.
        String3 = vbNullString
    Next Key1
            
    ' Define the the destination array ('dData'),
    ' a 2D one-based one-column string array with the same number of rows
    ' as the number of rows of the source array, .
    Dim dData() As String: ReDim dData(1 To rCount, 1 To 1)
            
    Dim String2 As String
            
    ' Loop through the rows of the source array...
    For r = 1 To rCount
        ' Write the 2nd column value, converted to a string, to a variable.
        String2 = CStr(sData(r, 2))
        ' Write the dictionary item associated to the key
        ' for the 1st column value to a variable.
        String3 = dict(sData(r, 1))
        If Len(String2) = 0 Then ' the 2nd column value is blank
            If Len(String3) > 0 Then ' the current string is not an empty string
                ' Write just the 3rd column (concatenated) strings.
                dData(r, 1) = String3
            'Else ' the current string is an empty string; do nothing
                ' Note that each element of the destination array is initially
                ' an empty string since it was declared 'As String'.
            End If
        Else ' the 2nd column value is not blank
            If Len(String3) > 0 Then ' the current string is not an empty string
                ' Concatenate the 2nd and 3rd column strings.
                dData(r, 1) = String2 & dDelimiter & String3
            Else ' the current string is an empty string
                ' Write just the 2nd column string.
                dData(r, 1) = String2
            End If
        End If
    Next r
    
    ' Write the values from the destination array to the 2nd column
    ' of the source data range (no headers).
    srg.Columns(2).Value = dData
    
    ' Clear the 3rd column of the source table range (has headers).
    strg.Columns(3).Clear

End Sub

Please, try the next version. It should do what (I understood) you need:

Sub CombineRangesOneColumnEmptyRemoved()
   Dim sh As Worksheet, lastR As Long, arr, arrDict, dict As Object
   Dim arrDB, arrDC, mtch, arrFin, i As Long, j As Long, k As Long
   
   Set sh = ActiveSheet
   lastR = sh.Range("A" & sh.rows.count).End(xlUp).row
   
   arr = sh.Range("A2:C" & lastR).Value2
   Set dict = CreateObject("Scripting.Dictionary")
   
   For i = 1 To UBound(arr)
        If Not dict.Exists(arr(i, 1)) Then
            dict.Add arr(i, 1), Array(arr(i, 2), arr(i, 3))   'place the strings from columns B and C
        Else
            arrDict = dict(arr(i, 1))                         'extract the array from dict items (it cnnot be modified inside the item)
            arrDict(0) = arrDict(0) & "|" & arr(i, 2)         'place in the array first element the strings collected from B:B
            arrDC = Split(arrDict(1), vbLf)                   'try splitting the second array element (string(s) from C:C)
            If UBound(arrDC) = 0 Then                         'if only one element(for second occurrence):
                    If arrDict(1) <> arr(i, 3) And arr(i, 3) <> "" Then 'not add it to the string if empty or already existing
                        arrDict(1) = arrDict(1) & vbLf & arr(i, 3)
                    End If
                   dict(arr(i, 1)) = arrDict
            ElseIf UBound(arrDC) = -1 Then                      'nothing (arrDict(1) is empty)
                  dict(arr(i, 1)) = Array(arrDict(0), arr(i, 3)) 'place the string of the third column (even empty...)
            Else
                    mtch = Application.match(arr(i, 3), arrDC, 0) 'check unicity of the string from C:C
                    If IsError(mtch) Then                                          'only if not existing:
                        arrDict(1) = arrDict(1) & IIf(arr(i, 3) = "", "", vbLf & arr(i, 3))       'add it to the string to be used in the next step
                    End If
                    dict(arr(i, 1)) = arrDict                                        'put back the changed array in the dictionary item
            End If
        End If
   Next i

   ReDim arrFin(1 To UBound(arr), 1 To 1): k = 1                  'redim the final array and initialize k (used to fill the array)
   For i = 0 To dict.count - 1                                    'iterate between the dictionary keys/items:
        arrDict = dict.Items()(i)                                 'place the item array in an array
        arrDB = Split(arrDict(0), "|")                           'obtain an array of B:B strins from the item first array element
        For j = 0 To UBound(arrDB)   'how many unique keys exists!
                arrFin(k, 1) = arrDB(j) & IIf(arrDict(1) = "", "", vbLf & arrDict(1)) 'build the string of the second column
                k = k + 1
        Next j
   Next i
   'drop the processed result near the existing range:
   sh.Range("D2").Resize(UBound(arrFin), 1).Value2 = arrFin
End Sub

If after testing it, nothing inconvenient appears, you may ReDim arrFin to have two columns, the code will load it without any code modification, but its content will be dropped in "B2" resized for two columns (Resize(UBound(arrFin), 2)). In this way, D:D will be errased in the same step.

Just for alternatives sake:

Formula in E2:

=TEXTJOIN(CHAR(10),,B2,UNIQUE(FILTER(C$2:C$10,A$2:A$10=A2)))

Or, if available, spill all results in a single go:

=BYROW(A2:B10,LAMBDA(x,TEXTJOIN(CHAR(10),,INDEX(x,2),UNIQUE(FILTER(C$2:C$10,A$2:A$10=INDEX(x,1))))))