Tom’s Tutorials For Excel: Concatenating Multiple Items For Unique Partners
Here’s how you can take several associated items that are located in their own cells, and concatenate them as a single string to be housed into one cell.
In the picture, you see Primary Items in column A, which are repeated in each row to accommodate each of their respective Parts Needed. The task is to show each Primary Item only once in column A, with its collective Parts Needed shown in one cell in column B.
Notes (colored green) in the below macro help you to follow the process, including a few tricks:
• Insert a row at each change in value for column A.
• Use those empty rows to identify individual Areas (blocks of Primary Items).
• Append each set of Parts Needed items with a comma and a space.
• Use the Range syntax with Columns to delete a range of columns.
Sub MultipleJoins()
'Turn off ScreenUpdating.
Application.ScreenUpdating = False
'Declare Long variable for rows; and Range variables for areas and cells.
Dim xRow&, area As Range, cell As Range
'Insert an empty row at each change in Primary Item in column A.
For xRow = Cells(Rows.Count, 1).End(xlUp).Row To 2 Step -1
If Cells(xRow, 1).Value <> Cells(xRow - 1, 1).Value Then _
Rows(xRow).Insert
Next xRow
'Insert a column at column A to list unique Primary Item names.
Columns(1).Insert
'Open a For...Next loop for each noncontiguous Primary Item area.
For Each area In Columns(2).SpecialCells(2).Areas
'Place a unique Primary Item name from the block of duplicates.
Cells(area.Row, 1).Value = area.Cells(1, 1).Value
'Nest a For...Next loop to join (separated by a commma and a space)
'the "Parts Needed" items into a single cell on the same row as the
'unique Primary Item.
For Each cell In area.Offset(0, 1).Resize(area.Rows.Count, 1)
With Cells(area.Row, 4)
If Len(.Value) > 0 Then
.Value = .Value & ", " & cell.Value
Else
.Value = cell.Value
End If
End With
'Continue and close the nested For...Next loop.
Next cell
'Continue and close the For...Next areas loop.
Next area
'Delete columns B and C which actually were the original data.
'You can do this because inserted column A now lists unique Primary Items.
Range(Columns(2), Columns(3)).Delete
'Delete rows based on empty cells between unique Primary Items in column A.
Columns(1).SpecialCells(4).EntireRow.Delete
'AutoFit the columns to make the final result look more readable.
Columns.AutoFit
'Turn on ScreenUpdating.
Application.ScreenUpdating = True
End Sub
Tom,
Just wanted to give a quick thanks, I had been struggling with the VBA code to handle mailing selected work sheets in Excel to different people, your solution [ Sub Mail_Every_Worksheet() ] worked great!
Thanks
Jim
Thank you Jim! And thanks for following my Excel blog!
-Tom
Tom
Can this be done in a reverse manner i.e. to get “What you have” from “What You Want”?
Thanks for following my Excel blog.
Yes, this can be done in reverse, if…
• Your items are listed in column A as shown, with a header cell in A1.
• Your parts needed are listed in column B as shown, with a header cell in B1.
• Your delimiter is a comma between the parts needed as shown (if not, change the text to files part of the code)
…then this macro will do what you ask for, which I tested and works fine:
Sub ReverseList()
Dim NextRow&, LastRow&, xRow&, LastColumn&, xColumn&
NextRow = 2: LastRow = Cells(Rows.Count, 1).End(xlUp).Row
LastColumn = Cells.Find(What:=”*”, After:=Range(“A1”), SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
Application.ScreenUpdating = False
Range(Columns(3), Columns(LastColumn)).Clear
Range(“C1:D1”).Value = Array(“Primary Item”, “Parts needed”)
Range(“B2:B” & LastRow).TextToColumns Destination:=Range(“E2″), DataType:=xlDelimited, Comma:=True
For xRow = 2 To LastRow
LastColumn = Cells(xRow, Cells.Columns.Count).End(xlToLeft).Column
If Len(Cells(xRow, 5).Value) > 0 Then
For xColumn = 5 To LastColumn
Cells(NextRow, 3).Value = Cells(xRow, 1).Value
Cells(NextRow, 4).Value = Cells(xRow, xColumn).Value
NextRow = NextRow + 1
Next xColumn
End If
Next xRow
Range(Columns(3), Columns(4)).AutoFit
LastColumn = Cells.Find(What:=”*”, After:=Range(“A1”), SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
Range(Columns(5), Columns(LastColumn)).Clear
‘Optional
‘Range(Columns(1), Columns(2)).Delete
Application.ScreenUpdating = True
End Sub
ConcatenateX function in DAX does this.
Thanks David.
If you can help me understand please, two questions:
(1) Is this function new in 2016, and/or backwards compatible?
(2) If I have this (given the duplicate check for column A per my original post)
First Last
Steve Jones
Steve Jones
Jason Smith
Would I end up with
First Last
Steve Jones
Jason Smith
or
Steve Jones, Jones
Jason Smith
I ask because, without the function in front of me and only able to look at the documentation, I don’t see a duplicate compilation provision for (in this example) column A.
Thanks.
Hi Tom, Thanks for this useful posting!! In this macro you are Area method by inserting blank rows in same ranges. but could you please do this without using area method, if we need in other sheets or other workbook using range or cell method..Appreciate if you respond. Thank you!
Here is code below for unique value for Column A but I need their corresponding values separated by commas for unique value in column E.
Dim xRow, cell As Range
Dim LR As Long
LR = ws1.Cells(Rows.Count, 1).End(xlUp).Row
Dim i As Long
For xRow = 2 To LR Step 1
i = Cells(Rows.Count, 4).End(xlUp).Row + 1
If Cells(xRow, 1).Value Cells(xRow + 1, 1).Value Then
Range(“D” & i) = Rows(xRow).Value
End If
Next
You asked a similar question on my Excel Facebook page at https://www.atlaspm.com/toms-tutorials-for-excel/toms-tutorials-for-excel-concatenating-multiple-items-for-unique-partners/. Please see if my reply there answers your question.