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 not 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
请尝试下一个代码。它使用字典和数组来保存、处理和返回必要的字符串。它将按任意顺序处理所有类别（A:A 中唯一）：
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
上面的代码假设我在评论中写的内容在一段时间之前放置，并且您没有确认/确认...
Edited:
请测试下一个版本。它将仅返回保留连接的 B:C 列值的列，并跳过 C:C 中的空值（如果是这种情况）。它也将在 D:D 中回归。测试后，如果它满足您的需要，只需将最后一行代码中的“D”更改为“B”即可：
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