Combine multiple rows into one row

**KelMel** · 12-01-2011, 01:25 PM

Hello,

I need to combine data from multiple rows into one row. I feel like I've tried everything I know, from merging to various formulas, and I downloaded a merge add-in, all to no avail. My worksheet has over 6,000 lines and I'm desperate to get this done. Your help is greatly appreciated!

I've attached a sample worksheet with an example of my problem and how I'd like it to look when complete. Thanks!

**tigeravatar** · 12-01-2011, 02:35 PM

KelMel,

Attached is a modified version of your example workbook. It contains a button named "Combine" which is assigned to the following macro:

Sub tgr()
    
    Dim arrUnq As Variant
    Dim arrData() As Variant
    Dim r As Long, c As Long
    
    Application.ScreenUpdating = False
    With Intersect(ActiveSheet.UsedRange, Columns(Rows(1).Find("mail").Column))
        .AdvancedFilter xlFilterCopy, , Cells(1, Columns.Count), True
        arrUnq = Application.Transpose(Range(Cells(2, Columns.Count), Cells(1, Columns.Count).End(xlDown)).Value)
        Columns(Columns.Count).Delete
        ReDim arrData(1 To UBound(arrUnq), 1 To ActiveSheet.UsedRange.Columns.Count)
        For r = 1 To UBound(arrData, 1)
            .AutoFilter 1, arrUnq(r)
            For c = 1 To UBound(arrData, 2)
                arrData(r, c) = Cells(1, c).End(xlDown).Text
            Next c
        Next r
        .AutoFilter
    End With
    
    ActiveSheet.UsedRange.Offset(1).ClearContents
    ActiveSheet.UsedRange.Offset(1).Resize(UBound(arrData, 1)).Value = arrData
    Application.ScreenUpdating = True
    
End Sub

**KelMel** · 12-08-2011, 12:05 PM

Wow! You rock. You have no idea how much time you saved me. Thank you!!!

**KelMel** · 12-08-2011, 12:07 PM

Oops. Macro not working.

**KelMel** · 12-08-2011, 01:01 PM

Attachment for tigeravatar

**KelMel** · 12-08-2011, 01:14 PM

tigeravatar, here is the attachment to use. The last one didn't have any duplicates. Dumb. Sorry.

**tigeravatar** · 12-08-2011, 01:38 PM

KelMel,

Modifed code so that it uses combined first name & last name to determine duplicates instead of email addresses, and then it combines rows based on that, give it a try:

Sub tgr()
    
    Dim FirstCol As String
    Dim LastCol As String
    Dim arrUnq As Variant
    Dim arrData() As Variant
    Dim r As Long, c As Long
    
    FirstCol = Split(Rows(1).Find("First", , , xlWhole).Address, "$")(1)
    LastCol = Split(Rows(1).Find("Last", , , xlWhole).Address, "$")(1)
    
    Application.ScreenUpdating = False
    With Intersect(ActiveSheet.UsedRange.EntireRow, Columns(Columns.Count - 1))
        .Formula = "=" & FirstCol & .Row & "&"" ""&" & LastCol & .Row
        .Value = .Value
        .AdvancedFilter xlFilterCopy, , .Offset(, 1).Resize(1), True
        arrUnq = Application.Transpose(Range(Cells(2, Columns.Count), Cells(1, Columns.Count).End(xlDown)).Value)
        .Resize(, 2).EntireColumn.Delete
    End With
    
    With Intersect(ActiveSheet.UsedRange, Columns(FirstCol & ":" & LastCol))
        ReDim arrData(1 To UBound(arrUnq), 1 To ActiveSheet.UsedRange.Columns.Count)
        For r = 1 To UBound(arrData, 1)
            .AutoFilter 1, Split(arrUnq(r), " ")(0)
            .AutoFilter 2, Split(arrUnq(r), " ")(1)
            For c = 1 To UBound(arrData, 2)
                arrData(r, c) = Cells(1, c).End(xlDown).Text
            Next c
        Next r
        .AutoFilter
    End With
    
    ActiveSheet.UsedRange.Offset(1).ClearContents
    ActiveSheet.UsedRange.Offset(1).Resize(UBound(arrData, 1)).Value = arrData
    Application.ScreenUpdating = True
    
End Sub