Tom’s Tutorials For Excel: Concatenating Multiple Items For Unique Partners

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

Share Button
Posted in Tom's Tutorials for Excel
Tags: , , , , , , , , , , , , ,
8 comments on “Tom’s Tutorials For Excel: Concatenating Multiple Items For Unique Partners
  1. Jim says:

    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

  2. Thong says:

    Tom

    Can this be done in a reverse manner i.e. to get “What you have” from “What You Want”?

    • Tom Urtis says:

      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

  3. David Hager says:

    ConcatenateX function in DAX does this.

    • Tom Urtis says:

      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.

  4. Deo Ramesh says:

    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

Leave a Reply to David Hager Cancel reply

Your email address will not be published. Required fields are marked *

*