Concatenate Multiple Rows with same Unique Identifier

[kparadise]

Hello,

Have a question for excel. I have a sheet with a large list of records. Each record has an ID, but is not unique due to multiple attributes which need to be accounted for, for each ID. Because these records are split, what I am trying to do is build another column at the end of my spreadsheet which will combine all the data from each unique ID into one cell. I will try to show below. Please notice, the combination of A2:B3 are duplicates, I wanted to include this in the example because I want to make sure if there are duplicates, I want to remove those from the results. I would put carriage returns in the results area.

	A	B	C
1	ID	Type	Results
2	A-123	Cat-big	Cat-big Cat-small Dog-big Dog-small Dog-tiny
3	A-123	Cat-big	Cat-big Cat-small Dog-big Dog-small Dog-tiny
4	A-123	Cat-small	Cat-big Cat-small Dog-big Dog-small Dog-tiny
5	A-123	Dog-big	Cat-big Cat-small Dog-big Dog-small Dog-tiny
6	B-123	Dog-small	Dog-small Dog-tiny
7	B-123	Dog-tiny	Dog-small Dog-tiny
8	A-987	Cat-tiny	Cat-tiny
9	A-777	Cat-large	Cat-large
10	A-555	Bull-large	Bull-large Bull-skinny
11	A-555	Bull-skinny	Bull-large Bull-skinny

<tbody>
</tbody>

 

[Fluff]

Will your data always be sorted as shown?

 

[kparadise]

Will your data always be sorted as shown?

It will always be sorted by ID before I need this task to be completed.

 

[Fluff]

In that case, how about

Sub kparadise()
   Dim Cl As Range
   Dim Dic As Object
   
   Set Dic = CreateObject("scripting.dictionary")
   For Each Cl In Range("A2", Range("A" & Rows.Count).End(xlUp))
      If Not Dic.Exists(Cl.Value) Then
         Cl.Offset(, 2).Value = Cl.Offset(, 1).Value
         Dic.Add Cl.Value, Array(Cl.Offset(, 2), CreateObject("scripting.dictionary"))
         Dic(Cl.Value)(1)(Cl.Offset(, 1).Value) = Empty
      ElseIf Not Dic(Cl.Value)(1).Exists(Cl.Offset(, 1).Value) Then
         Dic(Cl.Value)(0).Value = Dic(Cl.Value)(0).Value & vbLf & Cl.Offset(, 1).Value
         Dic(Cl.Value)(1)(Cl.Offset(, 1).Value) = Empty
      End If
   Next Cl
   With Range("c2", Range("A" & Rows.Count).End(xlUp).Offset(, 2))
      .SpecialCells(xlBlanks).FormulaR1C1 = "=r[-1]c"
      .Value = .Value
   End With
End Sub

 

[kparadise]

In that case, how about

Sub kparadise()
   Dim Cl As Range
   Dim Dic As Object
   
   Set Dic = CreateObject("scripting.dictionary")
   For Each Cl In Range("A2", Range("A" & Rows.Count).End(xlUp))
      If Not Dic.Exists(Cl.Value) Then
         Cl.Offset(, 2).Value = Cl.Offset(, 1).Value
         Dic.Add Cl.Value, Array(Cl.Offset(, 2), CreateObject("scripting.dictionary"))
         Dic(Cl.Value)(1)(Cl.Offset(, 1).Value) = Empty
      ElseIf Not Dic(Cl.Value)(1).Exists(Cl.Offset(, 1).Value) Then
         Dic(Cl.Value)(0).Value = Dic(Cl.Value)(0).Value & vbLf & Cl.Offset(, 1).Value
         Dic(Cl.Value)(1)(Cl.Offset(, 1).Value) = Empty
      End If
   Next Cl
   With Range("c2", Range("A" & Rows.Count).End(xlUp).Offset(, 2))
      .SpecialCells(xlBlanks).FormulaR1C1 = "=r[-1]c"
      .Value = .Value
   End With
End Sub

How would this code change if I needed to make it dynamic; because the spreadsheet has many more columns, and it will contain a different amount of columns each time possible; and I would like the formula at the very end of the last column in the current sheet. Can you change this code to search for the headers instead? We can use the ID column as the amount of rows to copy the formula down.

 

[Fluff]

Firstly, does the code do what you want with your sample data?
Secondly, it's always best to state what you need upfront, rather than providing sample data that is not representative of your actual data.

What headers should it search for & what row are they in?

 

[kparadise]

Firstly, does the code do what you want with your sample data?
Secondly, it's always best to state what you need upfront, rather than providing sample data that is not representative of your actual data.

What headers should it search for & what row are they in?

The above code does work, yes.

Understood, I thought it was going to be a formula I was just going to be able to change. I was not positive it would be VBA code. The columns headers will always be in row 1. The ID column is called "ID ID" and the other field will be called "Type Desc".

 

[Fluff]

Ok, how about

Sub kparadise()
   Dim Cl As Range, Clm1 As Range, Clm2 As Range, Clm3 As Range
   Dim Dic As Object
   Dim i As Long
   
   Set Clm1 = Range("1:1").Find("ID", , , xlWhole, , , False, , False)
   Set Clm2 = Range("1:1").Find("Type desc", , , xlWhole, , , False, , False)
   Set Clm3 = Cells(1, Columns.Count).End(xlToLeft).Offset(, 1)
   
   If Clm1 Is Nothing Or Clm2 Is Nothing Then
      MsgBox "header not found"
      Exit Sub
   End If
   
   Set Dic = CreateObject("scripting.dictionary")
   Set Clm1 = Range(Clm1.Offset(1), Clm1.End(xlDown))
   Set Clm2 = Clm2.Offset(1).Resize(Clm1.Count)
   Set Clm3 = Clm3.Offset(1).Resize(Clm1.Count)
   For Each Cl In Clm1
      i = i + 1
      If Not Dic.Exists(Cl.Value) Then
         Clm3(i).Value = Clm2(i).Value
         Dic.Add Cl.Value, Array(Clm3(i), CreateObject("scripting.dictionary"))
         Dic(Cl.Value)(1)(Clm2(i).Value) = Empty
      ElseIf Not Dic(Cl.Value)(1).Exists(Clm2(i).Value) Then
         Dic(Cl.Value)(0).Value = Dic(Cl.Value)(0).Value & vbLf & Clm2(i).Value
         Dic(Cl.Value)(1)(Clm2(i).Value) = Empty
      End If
   Next Cl
   With Clm3
      .SpecialCells(xlBlanks).FormulaR1C1 = "=r[-1]c"
      .Value = .Value
   End With
End Sub

If you have Office 365 then you may be able to do it using TEXTJOIN

 

[kparadise]

Ok, how about

Sub kparadise()
   Dim Cl As Range, Clm1 As Range, Clm2 As Range, Clm3 As Range
   Dim Dic As Object
   Dim i As Long
   
   Set Clm1 = Range("1:1").Find("ID", , , xlWhole, , , False, , False)
   Set Clm2 = Range("1:1").Find("Type desc", , , xlWhole, , , False, , False)
   Set Clm3 = Cells(1, Columns.Count).End(xlToLeft).Offset(, 1)
   
   If Clm1 Is Nothing Or Clm2 Is Nothing Then
      MsgBox "header not found"
      Exit Sub
   End If
   
   Set Dic = CreateObject("scripting.dictionary")
   Set Clm1 = Range(Clm1.Offset(1), Clm1.End(xlDown))
   Set Clm2 = Clm2.Offset(1).Resize(Clm1.Count)
   Set Clm3 = Clm3.Offset(1).Resize(Clm1.Count)
   For Each Cl In Clm1
      i = i + 1
      If Not Dic.Exists(Cl.Value) Then
         Clm3(i).Value = Clm2(i).Value
         Dic.Add Cl.Value, Array(Clm3(i), CreateObject("scripting.dictionary"))
         Dic(Cl.Value)(1)(Clm2(i).Value) = Empty
      ElseIf Not Dic(Cl.Value)(1).Exists(Clm2(i).Value) Then
         Dic(Cl.Value)(0).Value = Dic(Cl.Value)(0).Value & vbLf & Clm2(i).Value
         Dic(Cl.Value)(1)(Clm2(i).Value) = Empty
      End If
   Next Cl
   With Clm3
      .SpecialCells(xlBlanks).FormulaR1C1 = "=r[-1]c"
      .Value = .Value
   End With
End Sub

If you have Office 365 then you may be able to do it using TEXTJOIN

Works perfectly. Thank you.

So there is another column I need to run this same code on after running the above. Can I just change the Clm2 value within the double quotations? Or do I need to change something else as well? If I want to run them back to back; do I need to change the "Clm2" to "Clm2xx" or something?

 

[Fluff]

You can change the part in red & it should work happily

Set Clm2 = Range("1:1").Find("[COLOR=#ff0000]Type desc[/COLOR]", , , xlWhole, , , False, , False)

but you will need to ensure there is a column header in the new column, otherwise you will overwrite the results

 

[kparadise]

You can change the part in red & it should work happily

Set Clm2 = Range("1:1").Find("[COLOR=#ff0000]Type desc[/COLOR]", , , xlWhole, , , False, , False)

but you will need to ensure there is a column header in the new column, otherwise you will overwrite the results

Can I add a header in that above code by using code in the beginning?

<code>
Dim rngHeaders As Range

Set rngHeaders = Range("1:1")

rngHeaders.Offset(0, 1).Value = "Results"

or is that way off?
</code>