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 
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
CodePudding user response：
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.
CodePudding user response：
Combine Unique Values
Sub Extract_unique_values_and_combine_in_adjacent_cells()
Const vDelimiter As String = vbLf
Const dDelimiter As String = vbLf
Dim ws As Worksheet: Set ws = ActiveSheet ' improve!
Dim strg As Range: Set strg = ws.Range("A1").CurrentRegion
Dim srCount As Long: srCount = strg.Rows.Count - 1
Dim srg As Range: Set srg = strg.Resize(srCount).Offset(1)
Dim sData() As Variant: sData = srg.Value
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
dict.CompareMode = vbTextCompare
Dim uKey As Variant
Dim vKey As Variant
Dim r As Long
For r = 1 To srCount
uKey = sData(r, 1)
If Not dict.Exists(uKey) Then
Set dict(uKey) = CreateObject("Scripting.Dictionary")
dict(uKey).CompareMode = vbTextCompare
End If
vKey = sData(r, 3)
If Not IsError(vKey) Then
If Len(CStr(vKey)) > 0 Then
dict(uKey)(vKey) = Empty
End If
End If
Next r
Dim vLen As Long: vLen = Len(vDelimiter)
Dim n As Long
Dim vString As String
For Each uKey In dict.Keys
For Each vKey In dict(uKey).Keys
vString = vString & vKey & vDelimiter
Next vKey
If Len(vString) > 0 Then
vString = Left(vString, Len(vString) - vLen)
End If
dict(uKey) = vString
vString = vbNullString
Next uKey
Dim dData() As String: ReDim dData(1 To srCount, 1 To 1)
Dim dString As String
For r = 1 To srCount
dString = CStr(sData(r, 2))
vString = dict(sData(r, 1))
If Len(dString) = 0 Then
If Len(vString) > 0 Then
dData(r, 1) = vString
End If
Else
If Len(vString) > 0 Then
dData(r, 1) = dString & dDelimiter & vString
Else
dData(r, 1) = dString
End If
End If
Next r
srg.Columns(2).Value = dData
strg.Columns(3).Clear
End Sub
CodePudding user response：
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))))))