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

Question

I need to combine unique values from ranges (with condition) into another ranges on the same rows.
Actually, I post a similar question two days ago Link and the provided answer works as I formulated that mentioned question.
But later, I faced a new issues and I preferred to ask a new one to make it more clear :
(1) if all cells on a separate range e.g [C7:C8] have empty value,
then I got on that line mtch = Application.Match(arr(i, 3), arrDC, 0)
Run-time error '13':Type mismatch
I can use On Error Resume Next before that line ,but I think it’s not the proper way to handle that error.
(2) if some cells or all on a separate range e.g [B9:B10] have empty value,
then I got blank lines (on top the combined values) at the final result.
This is a link for the provided example with the expected output.
In advance, great thanks for your learning support and help.
Sub CombineRangesOneColumn_v2()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
'_________________________________________
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:
If arrDC(0) <> arr(i, 3) Then
arrDict(1) = arrDict(1) & IIf(arr(i, 3) = "", "", vbLf & arr(i, 3)) 'add to it the value from C:C, separated by vbLf
End If
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
End If
dict(arr(i, 1)) = arrDict 'put back the array in the dictionary item
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 'place the dictionry key per each iteration
arrFin(k, 1) = arrDB(j) & 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 (for easy visual comparison):
sh.Range("D2").Resize(UBound(arrFin), 1).Value2 = arrFin
'_______________________________________________
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub

Answer 1

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

Answer 2

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.

Answer 3

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))))))