Super User is a question and answer site for computer enthusiasts and power users. It's 100% free, no registration required.

Sign up
Here's how it works:
  1. Anybody can ask a question
  2. Anybody can answer
  3. The best answers are voted up and rise to the top

I have an excel sheet of around 50,000 records of something like this:

email   product  info   moreinfo   866   data   data1   960   data   data1   976   data   data1   884   data   data1   1010   data   data1   834   data   data1   981   data   data1   935   data   data1   832   data   data1   934   data   data1

I need to convert it to something like this:

email   product   info   moreinfo   866   data   data1   960   data   data1   976,884   data   data1   1010   data   data1   834   data   data1   981   data   data1   935,832,934   data   data1

I need rows with duplicate emails to be merged into one and information from column B to be merged into one record for that email address. I've tried a few macros but to no avail. Can you help me? I'm a bit confused here. Thanks!

Edit: I'm using Excel 2011 on the Mac.

share|improve this question
you don't say how data is to be merged, or how data looks like, what about the other columns C? – Jook Nov 7 '12 at 11:28
Part of the answer to SU488278 though for Excel 2007 might 'point you in the right direction'. – pnuts Nov 7 '12 at 17:20

I have had requirements like this a few times over the years so I coded a general routine. I have lost the source of that routine and have recoded from memory. I have tested the new version but cannot absolutely guarantee it is error free so take a copy of your data before you try it.

The routine relies on two arrays. ColMatch tells it which columns must be equal for two rows to match. ColMerge tells it which columns to merge. Every column must be specified in one of those arrays.

For my test data, I match on columns 1, 2, 3 and 5 and merge columns 4 and 6. I define this so:

  ColMatch = Array(1, 2, 3, 5)
  ColMerge = Array(4, 6)

You will have to amend these statements to your requirements. Your question implies they should be:

  ColMatch = Array(1, 3, 4)
  ColMerge = Array(2)

The routine also uses a constant Separator which is placed before each appended value. I have set it to vbLf so I get each value of a different row. You want comma, so:

  Const Separator As String = ","

I do not think there is anything else you need to change. However, I suggets you work down the macro carefully. I hope I have included enough comments for you to understand how it works. Come back with questions if necessary.

On my system, it takes about 2 minutes to process 51,800 rows so I use the status bar as a crude progress indicator.

This shows the initial state of my test data.

Initial state of my test data

This shows how it has changed after the macro has been run.

State of data after macro has run

Hope this helps.

Option Explicit
Sub MergeRows()

  ' Merges adjacent rows for which all columns listed in ColMatch are equal
  ' by appending the contents of the other columns from the second row to
  ' the first row and then deleting the second row.

  Dim CheckOK As Boolean
  Dim ColCrnt As Long
  Dim ColLast As Long
  Dim ColMatch() As Variant
  Dim ColMerge() As Variant
  Dim InxMatch As Long
  Dim InxMerge As Long
  Dim RowCrnt As Long
  Dim RowLast As Long
  Dim RowsMatch As Boolean
  Dim TimeStart As Single

  ' Defines the first row to be considered for merging.  This avoids
  ' looking at header rows (not very important) and allows a restart
  ' from row 600 or whatever (might be important).
  Const rowDataFirst As Long = 2

  ' Defines the string to be placed between the value in the first row
  ' and the value from the second row.
  Const Separator As String = vbLf

 ' Speeds up processing
  Application.ScreenUpdating = False

  ' Stops the code from being interrupted by event routines
  Application.EnableEvents = False

  ' Use status bar as a progress indicator
  Application.DisplayStatusBar = True

  ' Record seconds since midnight at start of routine.
  TimeStart = Timer

  ' Defines the columns which must have the same values in two
  ' adjacent rows for the second row to be merged into the
  ' first row.  Column numbers must be in ascending order.
  ColMatch = Array(1, 2, 3, 5)

  ' Defines the columns for which values from the second row
  ' are to be appended to the first row of a matching pair.
  ' Column numbers must be in ascending order.  ColMatch and
  ' ColMerge together must specify every used column.
  ColMerge = Array(4, 6)

  ' Replace "Merge" with the name of your worksheet
  With Worksheets("Merge")

    ' Find last used column and last used row
    ColLast = .Cells.Find("*", .Range("A1"), xlFormulas, xlWhole, _
                                         xlByColumns, xlPrevious).Column
    RowLast = .Cells.Find("*", .Range("A1"), xlFormulas, xlWhole, _
                                         xlByRows, xlPrevious).Row

    ' Validate column parameters.  Every column must be specified once
    ' in either ColMatch or ColMerge.
    InxMatch = 0        ' 0 = lower bound of array
    InxMerge = 0
    For ColCrnt = 1 To ColLast
      CheckOK = False   ' Set true if check successful
      If InxMatch > UBound(ColMatch) Then
        ' ColMatch array exhausted
        If ColCrnt = ColMatch(InxMatch) Then
          CheckOK = True
          InxMatch = InxMatch + 1
        End If
      End If
      If Not CheckOK Then
        If InxMerge > UBound(ColMerge) Then
          ' ColMerge array exhausted
          If ColCrnt = ColMerge(InxMerge) Then
            CheckOK = True
            InxMerge = InxMerge + 1
          End If
        End If
      End If
      If Not CheckOK Then
        Call MsgBox("I was unable to find column " & ColCrnt & " in either" & _
                    " ColMatch or ColMerge.  Please correct and try again.", _
        Exit Sub
      End If

    RowCrnt = rowDataFirst
    Do While True

      If RowCrnt Mod 100 = 0 Then
        ' Use status bar to indicate progress
        Application.StatusBar = "Row " & RowCrnt & " of " & RowLast
      End If

      ' Attempt to match RowCrnt and RowCrnt+1
      RowsMatch = True    ' Assume match until find otherwise
      For InxMatch = 0 To UBound(ColMatch)
        ColCrnt = ColMatch(InxMatch)
        If .Cells(RowCrnt, ColCrnt).Value <> _
           .Cells(RowCrnt + 1, ColCrnt).Value Then
          ' Rows do not match
          RowsMatch = False
          Exit For
        End If

      If RowsMatch Then
        ' Rows match.  Merge second into first.
        For InxMerge = 0 To UBound(ColMerge)
          ColCrnt = ColMerge(InxMerge)
          .Cells(RowCrnt, ColCrnt).Value = .Cells(RowCrnt, ColCrnt).Value & _
                                           Separator & _
                                           .Cells(RowCrnt + 1, ColCrnt).Value
        ' Second row merged into first.  Discard second row.
        .Rows(RowCrnt + 1).EntireRow.Delete
        ' RowLast has moved up.
        RowLast = RowLast - 1
        ' Do not step RowCrnt because there may be another match for it
        If RowCrnt = RowLast Then
          ' All rows checked.
          Exit Do
        End If
        ' Rows do not match.  RowCrnt no longer of interest.
        RowCrnt = RowCrnt + 1
        If RowCrnt = RowLast Then
          ' All rows checked.
          Exit Do
        End If
      End If
  End With

  ' Output duration of macro to Immediate window
  Debug.Print Format(Timer - TimeStart, "#,##0.00")

  Application.StatusBar = False
  Application.EnableEvents = True
  Application.ScreenUpdating = True

End Sub
share|improve this answer

Your Answer


By posting your answer, you agree to the privacy policy and terms of service.

Not the answer you're looking for? Browse other questions tagged or ask your own question.