Excel: Merge content in column based on ID

Question

I'm trying to merge rows that have the same ID. I've got it working, but the order of merging is not respected. It puts the last value of the same ID in first, instead of respecting the row order. Anybody who has a clue how to achieve this?

Input:

ID	Value
101
101	325grams
101	500grams
100
100	200 grams
100	1 kilo
100	3 kilo

Current situation:

ID	Value
101	500 grams, 325grams
100	3 kilo, 200 grams, 1 kilo

Desired solution:

ID	Value
101	325 grams, 500 grams
100	200 grams, 1 kilo, 3 kilo

CODE:

Sub Consolidate_Rows()
    
    Dim xRg         As Range
    Dim xRows       As Long
    Dim i           As Long, J As Long, K As Long
    
    On Error Resume Next
    Set xRg = Application.InputBox("Select Range:", "Consolidate selection", Selection.Address, , , , , 8)
    Set xRg = Range(Intersect(xRg, ActiveSheet.UsedRange).Address)
    
    If xRg Is Nothing Then Exit Sub
    xRows = xRg.Rows.Count
    For i = xRows To 2 Step -1
        For J = 1 To i - 1
            If xRg(i, 1).Value = xRg(J, 1).Value And J <> i Then
                For K = 2 To xRg.Columns.Count
                    If xRg(J, K).Value <> "" Then
                        If xRg(i, K).Value = "" Then
                            xRg(i, K) = xRg(J, K).Value
                        Else
                            xRg(i, K) = xRg(i, K).Value & "," & xRg(J, K).Value
                        End If
                    End If
                Next
                xRg(J, 1).EntireRow.Delete
                i = i - 1
                J = J - 1
            End If
        Next
    Next
    ActiveSheet.UsedRange.Columns.AutoFit
End Sub

Thanks a bunch!

EDIT: Changed the table to resemble my data more. Sorting of merged cells should not be based alphabetically, but on row order.

Answer 1

A couple of notes:

1. You can use a collection to check the input range instead of using OERN

2. Also you can leverage a dictionary and add the IDs and Values and then output to a range

---

Some suggestions:

• Name your variables to something meaningful (i is hard to understand, counter it's easier)
• Indent your code properly (you can use Rubberduckvba.com) to help you with data
• Try to break your code into pieces (e.g. first store data into an array, then check and concat, after clear the range, finally output it)
• Comment your code

---

Read code's comments and adjust it to fit your needs

Public Sub ConsolidateRows()
    
    ' Get user range input | Credits: https://stackoverflow.com/a/37545423/1521579
    Dim rangeCollection As Collection
    Set rangeCollection = New Collection
    rangeCollection.Add Application.InputBox(Prompt:="Select Range:", Title:="Consolidate selection", Default:=Selection.Address, Type:=8)
    
    Dim sourceRange As Range
    If TypeOf rangeCollection(1) Is Range Then Set sourceRange = rangeCollection(1)
    
    ' Exit if no selection was mage
    If sourceRange Is Nothing Then Exit Sub
    
    ' Read range into array
    Dim sourceArray As Variant
    sourceArray = sourceRange.Value
    
    ' Create a dictionary to store IDs and Values
    Dim targetDict As Object
    Set targetDict = CreateObject("Scripting.Dictionary")
    
    ' Loop through each row
    Dim rowCounter As Long
    For rowCounter = 1 To UBound(sourceArray)
        
        Select Case True
        ' Handle first row
        Case rowCounter = 1
            targetDict.Add Key:=CStr(sourceArray(rowCounter, 1)), Item:=sourceArray(rowCounter, 2)
        ' If ID is equal to previous concat with previous
        Case CStr(sourceArray(rowCounter, 1)) = CStr(sourceArray(rowCounter - 1, 1))
        ' If ID is not equal to previous add new item to dictionary
            targetDict(CStr(sourceArray(rowCounter, 1))) = targetDict(CStr(sourceArray(rowCounter, 1))) & "," & sourceArray(rowCounter, 2)
        Case Else
            targetDict.Add Key:=CStr(sourceArray(rowCounter, 1)), Item:=sourceArray(rowCounter, 2)
        End Select
        
    Next rowCounter
    
    ' Clear source range values
    sourceRange.Clear
    
    ' Output dictionary to the first cell in source range
    Dim targetRange As Range
    Set targetRange = sourceRange.Cells(1, 1)
    
    targetRange.Resize(targetDict.Count, 1).Value = Application.WorksheetFunction.Transpose(targetDict.keys)
    targetRange.Offset(0, 1).Resize(targetDict.Count, 1).Value = Application.WorksheetFunction.Transpose(targetDict.items)
    
    
End Sub

---

Let me know if it works

Answer 2

I found a solution for you on another SO post.

excel: how do i sort within a cell?

Your entire code should look like this now.

Sub Consolidate_Rows()
    
    Dim xRg         As Range
    Dim xRows       As Long
    Dim i           As Long, j As Long, K As Long
    
    On Error Resume Next
    Set xRg = Application.InputBox("Select Range:", "Consolidate selection", Selection.Address, , , , , 8)
    Set xRg = Range(Intersect(xRg, ActiveSheet.UsedRange).Address)
    
    If xRg Is Nothing Then Exit Sub
    xRows = xRg.Rows.Count
    For i = xRows To 2 Step -1
        For j = 1 To i - 1
            If xRg(i, 1).Value = xRg(j, 1).Value And j <> i Then
                For K = 2 To xRg.Columns.Count
                    If xRg(j, K).Value <> "" Then
                        If xRg(i, K).Value = "" Then
                            xRg(i, K) = xRg(j, K).Value
                        Else
                            xRg(i, K) = xRg(i, K).Value & "," & xRg(j, K).Value
                        End If
                    End If
                Next
                xRg(j, 1).EntireRow.Delete
                i = i - 1
                j = j - 1
            End If
        Next
    Next
    ActiveSheet.UsedRange.Columns.AutoFit
Call HSort
End Sub

Sub HSort()

Dim rng As Range, cell As Range
Dim i As Integer
Dim arr As Variant
Set rng = Range("B2:B3")
For Each cell In rng

    cell.Select
    arr = Split(ActiveCell.Text, ",")

    ' trim values so sort will work properly
    For i = LBound(arr) To UBound(arr)
        arr(i) = Trim(arr(i))
    Next i

    ' sort
    QuickSort arr, LBound(arr), UBound(arr)

    ' load sorted values back to cell
    Dim comma As String
    comma = ""
    ActiveCell = ""
    For i = LBound(arr) To UBound(arr)
        ActiveCell = ActiveCell & comma & CStr(arr(i))
        comma = ","
    Next i
    
Next cell

End Sub

Public Sub QuickSort(vArray As Variant, inLow As Long, inHi As Long)

Dim pivot   As Variant
Dim tmpSwap As Variant
Dim tmpLow  As Long
Dim tmpHi   As Long

  tmpLow = inLow
  tmpHi = inHi

  pivot = vArray((inLow + inHi) \ 2)

  While (tmpLow <= tmpHi)

     While (vArray(tmpLow) < pivot And tmpLow < inHi)
        tmpLow = tmpLow + 1
     Wend

     While (pivot < vArray(tmpHi) And tmpHi > inLow)
        tmpHi = tmpHi - 1
     Wend

     If (tmpLow <= tmpHi) Then
        tmpSwap = vArray(tmpLow)
        vArray(tmpLow) = vArray(tmpHi)
        vArray(tmpHi) = tmpSwap
        tmpLow = tmpLow + 1
        tmpHi = tmpHi - 1
     End If

  Wend

  If (inLow < tmpHi) Then QuickSort vArray, inLow, tmpHi
  If (tmpLow < inHi) Then QuickSort vArray, tmpLow, inHi

End Sub

Before:

After:

Answer 3

You can also do this using Power Query, available in Excel 2010+

• Select a cell in the data table
• Data => Get&Transform => from Table/Range
• In PQ, Home => Advanced Editor
  • Make note of the table name in Line 2
  • Replace the existing code with the MCode above
  • Change the table name in Line 2 to reflect your actual table name.
• The table is Grouped by the ID
  • The sorting and concatenation is done by the List.Accumulate and List.Sort functions.

M Code

let
    Source = Excel.CurrentWorkbook(){[Name="Table2"]}[Content],
    #"Changed Type" = Table.TransformColumnTypes(Source,{{"ID", Int64.Type}, {"Value", type text}}),
    #"Grouped Rows" = Table.Group(#"Changed Type", {"ID"}, {{"Grouped", each List.Accumulate(
           List.Sort([Value]), 
        "", (state, current)=> if state = "" then current else state & ", " & current), type text}})
in
    #"Grouped Rows"

Answer 4

This proposed solution:

• Uses Filter function to ensure the values extracted maintain the range row order.
• Uses a Dictionary to hold the unique Ids and all its corresponding values.

With the methods used there is no need to loop through data more than once.

Sub Consolidate_IDs_And_Values()
Const kTitle As String = "Consolidate selection"
Const kFml As String = "Transpose(""|""&#ID&""|""&#VAL)"
Dim Rng As Range, sMsg As String, sFml As String
Dim Dtn As Object
Dim aIds As Variant, aValues As Variant, aFilter As Variant
Dim vKey As Variant, sKey As String, L As Long

    Rem Set Input Range from User
    On Error Resume Next
    Set Rng = Application.InputBox( _
        "Select Range (excluding header and at least two columns):", _
        kTitle, Selection.Address, Type:=8)
    On Error GoTo 0
    
    Rem Validate Input Range
    If Rng Is Nothing Then
        MsgBox "Input box was cancelled.", , kTitle
        Exit Sub
    End If
    If Rng.Columns.Count < 2 Then
        MsgBox "Input range must have at least two columns.", , kTitle
        Exit Sub
    End If
    
    Rem Set IDs and Values Arrays
    With Rng
        aIds = Application.Transpose(.Columns(1).Value)
        sFml = Replace(Replace(kFml, "#ID", .Columns(1).Address), "#VAL", .Columns(2).Address)
        aValues = Application.Evaluate(sFml)
    End With
    
    Rem Set Dictionary
    Set Dtn = CreateObject("Scripting.Dictionary")
    
    Rem Add Unique ID's with all corresponding Values to Dictionary
    With Dtn
        For Each vKey In aIds
            If Not (.Exists(vKey)) Then
                
                Rem Filter Key Values
                sKey = "|" & vKey & "|"
                aFilter = Filter(aValues, sKey, True)
                aFilter = Join(aFilter, ", ")
                aFilter = Replace(aFilter, sKey & ", ", "")   'EDIT: this line is added to eliminate the Items with [Value]=empty
                aFilter = Replace(aFilter, sKey, "")

                Rem Filter Key & Values to Dictionary
                Dtn.Add vKey, aFilter
        
        End If: Next
        
        L = .Count
    
    End With
    
    With Rng
            
        Rem Delete Remaining Rows
        .Rows(1).Offset(L).Resize(.Rows.Count - L).EntireRow.Delete
        
        Rem Post Dictionary
        .Cells(1, 1).Resize(L).Value = Application.Transpose(Dtn.Keys)
        .Cells(1, 2).Resize(L).Value = Application.Transpose(Dtn.Items)
        
        .Columns.AutoFit

    End With

    End Sub

Before:

After: