Concatenate Multiple Rows with same Unique Identifier

kparadise

Board Regular
Joined
Aug 13, 2015
Messages
186
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

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
55,681
Office Version
  1. 365
Platform
  1. Windows
Will your data always be sorted as shown?
 

Some videos you may like

Excel Facts

Is there a shortcut key for strikethrough?
Ctrl+S is used for Save. Ctrl+5 is used for Strikethrough. Why Ctrl+5? When you use hashmarks to count |||| is 4, strike through to mean 5.

Fluff

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
55,681
Office Version
  1. 365
Platform
  1. Windows
In that case, how about
Code:
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

Board Regular
Joined
Aug 13, 2015
Messages
186
In that case, how about
Code:
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.
 
Last edited:

Fluff

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
55,681
Office Version
  1. 365
Platform
  1. Windows

ADVERTISEMENT

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

Board Regular
Joined
Aug 13, 2015
Messages
186
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

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
55,681
Office Version
  1. 365
Platform
  1. Windows

ADVERTISEMENT

Ok, how about
Code:
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
 
Last edited:

kparadise

Board Regular
Joined
Aug 13, 2015
Messages
186
Ok, how about
Code:
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

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
55,681
Office Version
  1. 365
Platform
  1. Windows
You can change the part in red & it should work happily
Code:
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

Board Regular
Joined
Aug 13, 2015
Messages
186
You can change the part in red & it should work happily
Code:
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>
 

Watch MrExcel Video

Forum statistics

Threads
1,127,844
Messages
5,627,219
Members
416,230
Latest member
jdaitchman

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top