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
 AB
1gene_idmature_miRNA
2D1hsa-miR-153,hsa-miR-101,hsa-miR-218
3D2hsa-miR-101,hsa-miR-135b
4D3hsa-miR-520b,hsa-miR-101
5D4hsa-miR-520b,hsa-miR-302d
6D5hsa-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
   
    Range("A:B").Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlYes, _
        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!
PayPal - The safer, easier way to pay online!

Comments