I need to extract the unique values from a separate ranges and concatenate to the adjacent column (offset (,-1) on the same range.
As you see on the below picture, I sort my dataset by column_A ,so all duplicate values on column_A will be together.
I need to put the duplicate values on column_A with the respective cells on the same rows into a variable Range e.g rng1 = [A2:C4],
Then extract unique values found on rng1.columns(3) and concatenate to each cell on rng1.columns(2) ,range(“B2:B4”)
By the same rng2 will be = [A5:C7] and so on.
The problem is I do know how when ID values is duplicates to put them and it’s adjacent cells on the same rows into a variable range and process it !
At end column C will be be deleted.
In advance, great thanks for your learning support.
Sub Extract_unique_values_and_combine_in_adjacent_cells()
Dim ws As Worksheet: Set ws = ActiveSheet
Dim rng As Range
Set rng = ws.Range("A2:C" & ws.Cells(Rows.Count, "A").End(xlUp).Row)
Dim arr: arr = rng.Value2
Dim i As Long
For i = LBound(arr) To UBound(arr)
On Error Resume Next 'skip error if i= 1
If arr(i, 1) = arr(i 1, 1) Or _
arr(i, 1) = arr(i - 1, 1) Then
arr(i, 2) = arr(i, 2) & vbLf & unique(ws.Range("C2:C4").Value2) 'I need (crg) to be dynamic
End If
On Error GoTo 0
Next i
rng.Value = arr
End Sub
Function unique(crg)
Dim cel, a
With CreateObject("scripting.dictionary")
For Each cel In crg
a = .Item(cel)
Next
unique = Join(.Keys, vbLf)
End With
End Function
CodePudding user response：
Please, try the next code. It uses a dictionary and arrays to keep, process and return the necessary strings. It will process all categories (unique in A:A) being in any order:
Sub CombineRanges()
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) & vbLf & arr(i, 3) 'add to it the value from C:C, separated by vbLf
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) & 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 2): 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) = dict.Keys()(i) 'place the dictionry key per each iteration
arrFin(k, 2) = 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), 2).Value2 = arrFin
End Sub
The above code assumes what I wrote in my comment placed some time before and you din not confirm/infirm...
Edited:
Please, test the next version. It will return only a column keeping the concatenated B:C columns value and skips the empty values in C:C, if the case. It will return in D:D, too. After testing, if it does what you need, just change "D" with "B" in the last code line:
Sub CombineRangesOneColumn()
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
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
End Sub