Merge Functions‎ > ‎

Merge Rows

PROBLEM:
"I have data with duplicate IDs in column A and some data in column B.  I need to reduce all the duplicate IDs into a single row for each ID while merging the column B values into a single cell delimited by a comma.  It would be a bonus if I could choose the delimiting character."

EXAMPLE                                                                           Sample File:     MergeRows.xls
BEFORE
 A B 1 gene_id mature_miRNA 2 D1 hsa-miR-153 3 D1 hsa-miR-218 4 D4 hsa-miR-302d 5 D2 hsa-miR-135b 6 D2 hsa-miR-101 7 D3 hsa-miR-101 8 D3 hsa-miR-520b 9 D5 hsa-miR-302d 10 D1 hsa-miR-101 11 D4 hsa-miR-520b 12 D1 hsa-miR-153

AFTER
 A B 1 gene_id mature_miRNA 2 D1 hsa-miR-153,hsa-miR-101,hsa-miR-218 3 D2 hsa-miR-101,hsa-miR-135b 4 D3 hsa-miR-520b,hsa-miR-101 5 D4 hsa-miR-520b,hsa-miR-302d 6 D5 hsa-miR-302d

SPECIFICATIONS:
1. Data can be any number of rows
2. Data may not be sorted
3. User can select the delimiter, comma is the default
4. User can opt to allow duplicate column B values in the results, or not

CODE

Option Explicit

Sub MergeGeneIDs()
'Jerry Beaucaire,  2/6/2012
'Merge rows matching on column A, opt to eliminate duplicates
Dim LR As Long, Rw As Long, Delim As String

If MsgBox("Eliminate duplicate values as they are merged?", _
vbYesNo, "Duplicates") = vbYes Then [C1] = True

Delim = Application.InputBox("What is the delimiter?", "Delimiter", ",", Type:=2)
If Delim = "False" Then Exit Sub
If Delim = "" Then Delim = ","

Application.ScreenUpdating = False
LR = Range("A" & Rows.Count).End(xlUp).Row

OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortTextAsNumbers

With Range("C2:C" & LR)
.Formula = "=IF(A2=A3,IF(\$C\$1,IF(ISNUMBER(SEARCH(B2,C3)), C3, C3 & """ & _
Delim & """ & B2), C3 & """ & Delim & """ & B2), B2)"
.Value = .Value
.Copy Range("B2")
.Formula = "=A2=A1"
End With

Range("C:C").AutoFilter
Range("C:C").AutoFilter 1, True
Range("C2:C" & LR).EntireRow.Delete xlShiftUp
Range("C:C").AutoFilter
Range("C:C").ClearContents
Columns.AutoFit

Application.ScreenUpdating = True
End Sub

Nothing says "thanks" like a steak dinner!