Merging similar rows of data, while appending unique data across multiple columns

Hi

This assumes your data is on sheet1, starting in A1 and you have a second sheet in your workbook called sheet2.

Sub bbb()
  Dim OutSH As Worksheet
  Set nodupes = CreateObject("Scripting.dictionary")
  Set OutSH = Sheets("Sheet2")
  For i = 1 To Cells(Rows.Count, 1).End(xlUp).Row
    holder = ""
    For j = 1 To 14
      holder = holder & Cells(i, j)
    Next j
    If Not nodupes.exists(holder) Then
      nodupes.Add Key:=holder, Item:=""
    End If
    For j = 15 To Cells(i, Columns.Count).End(xlToLeft).Column
      nodupes(holder) = nodupes(holder) & Cells(i, j)
    Next j
  Next i
  
  For Each ce In nodupes.keys
    outrow = OutSH.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
    For i = 1 To 14
      OutSH.Cells(outrow, i).Value = Mid(ce, i, 1)
    Next i
    
    For j = 1 To Len(nodupes(ce))
      OutSH.Cells(outrow, Columns.Count).End(xlToLeft).Offset(0, 1).Value = Mid(nodupes(ce), j, 1)
    Next j
    
  Next ce
  
  
End Sub

rylo

Hello and thank you for the very quick response and solution. I tested it and can see that it is almost there. I think I was incomplete in my example - While the info I gave described what I am trying to do - the characters in each column position were representing the contents of each cell (i.e. in reality - each cell can have multiple characters).

I created and have attached here a mockup of the data file which more accurately represents the source data. I also loaded and ran your suggested macro. I can see that it is doing the concatenation as I had hoped (brilliant!) - unfortunately it is parsing out the contents of each original cell into separate columns. Sorry for the incomplete specs. Would it take much further modification to avoid the cell parsing and move each cell content intact?

Thanks again for your support!

Data Merge Test v2.xlsm

Hi

OK, try this one.

Sub bbb()
  Dim OutSH As Worksheet
  Set nodupes = CreateObject("Scripting.dictionary")
  Set OutSH = Sheets("Sheet2")
  For i = 1 To Cells(Rows.Count, 1).End(xlUp).Row
    holder = ""
    For j = 1 To 14
      holder = holder & Cells(i, j) & ","
    Next j
    holder = Left(holder, Len(holder) - 1)
    If Not nodupes.exists(holder) Then
      nodupes.Add Key:=holder, Item:=""
    End If
    For j = 15 To Cells(i, Columns.Count).End(xlToLeft).Column
      nodupes(holder) = nodupes(holder) & Cells(i, j) & ","
    Next j
  Next i
  
  For Each ce In nodupes.keys
    outrow = OutSH.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
    'For i = 1 To 14
    '  OutSH.Cells(outrow, i).Value = Mid(ce, i, 1)
    'Next i
    arr = Split(ce, ",")
    For i = LBound(arr) To UBound(arr)
      OutSH.Cells(outrow, i + 1).Value = arr(i)
    Next i
    arr = Split(nodupes(ce), ",")
    
    'For j = 1 To Len(nodupes(ce))
    '  OutSH.Cells(outrow, Columns.Count).End(xlToLeft).Offset(0, 1).Value = Mid(nodupes(ce), j, 1)
    'Next j
    For j = LBound(arr) To UBound(arr)
      OutSH.Cells(outrow, Columns.Count).End(xlToLeft).Offset(0, 1).Value = arr(j)
    Next j
    
  Next ce
  
  
End Sub

rylo

This revised version worked perfectly!! You have saved me what would have otherwise been many many hours of tedious manual data manipulation. Thank you for your generous and incredibly speedy assistance.