VBA to Concatenate one column data in excel and dedupe additional line items

Beth0331

New Member
Joined
Jun 13, 2018
Messages
7
Hello, Apologies if this is already on here - I did a search but was not successful in finding anything that is exactly what I'm looking for (and my VBA knowledge is limited...)

I am looking to take data I have in an excel spreadsheet and concatenate one column's data for a referenced "tag" (User ID below) in a another column. For example below, for all line items with the user ID jdoe3 I would like to combine the colors into one line and discard the remaining lines. Are you able to help me with the VBA code I would need to do this?

Currently it looks like this:
NameUser IDColors
John Doejdoe3blue
John Doejdoe3yellow
John Doejdoe3green
John Doejdoe3orange
John Doejdoe3red
John Doejdoe3purple
Jane Smithjsmith5green
Jane Smithjsmith5orange
Jane Smithjsmith5red
George Phillipsgphillipsblue
George Phillipsgphillipsgreen

<tbody>
</tbody>


I would like it to look like this:
NameUser IDColors
John Doejdoe3blue, yellow, green, orange, red, purple
Jane Smithjsmith5green, orange, red
George Phillipsgphillipsblue, green

<tbody>
</tbody>

I'm using excel 2016

Thank You!
 

Excel Facts

Copy formula down without changing references
If you have =SUM(F2:F49) in F50; type Alt+' in F51 to copy =SUM(F2:F49) to F51, leaving the formula in edit mode. Change SUM to COUNT.

MickG

MrExcel MVP
Joined
Jan 9, 2008
Messages
14,841
Try this:-
Code:
[COLOR="Navy"]Sub[/COLOR] MG13Jun34
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range, Dn [COLOR="Navy"]As[/COLOR] Range, n [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Txt [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String,[/COLOR] nRng [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Set[/COLOR] Rng = Range("A2", Range("A" & Rows.Count).End(xlUp))
[COLOR="Navy"]With[/COLOR] CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
Txt = Dn.Value & Dn.Offset(, 1).Value
    [COLOR="Navy"]If[/COLOR] Not .Exists(Txt) [COLOR="Navy"]Then[/COLOR]
        .Add Txt, Dn
    [COLOR="Navy"]Else[/COLOR]
       .Item(Txt).Offset(, 2).Value = .Item(Txt).Offset(, 2).Value & ", " & Dn.Offset(, 3)
        [COLOR="Navy"]If[/COLOR] nRng [COLOR="Navy"]Is[/COLOR] Nothing [COLOR="Navy"]Then[/COLOR] [COLOR="Navy"]Set[/COLOR] nRng = Dn Else [COLOR="Navy"]Set[/COLOR] nRng = Union(nRng, Dn)
[COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR]
[COLOR="Navy"]If[/COLOR] Not nRng [COLOR="Navy"]Is[/COLOR] Nothing [COLOR="Navy"]Then[/COLOR] nRng.EntireRow.Delete
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]With[/COLOR]
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]
Regards Mick
 

Beth0331

New Member
Joined
Jun 13, 2018
Messages
7
Thank you Mick! Quick question, why does the DN.offset at the end go to 3? What does this line tell the query to do?
.Item(Txt).Offset(, 2).Value = .Item(Txt).Offset(, 2).Value & ", " & Dn.Offset(, 3)
 

Rick Rothstein

MrExcel MVP
Joined
Apr 18, 2011
Messages
37,638
Office Version
  1. 2019
  2. 2010
Platform
  1. Windows
Here is another macro that you can consider...
Code:
[table="width: 500"]
[tr]
	[td]Sub DedupeAndConcatenate()
  Dim LR As Long, Ar As Range
  LR = Cells(Rows.Count, "A").End(xlUp).Row
  Range("A2:A" & LR) = Evaluate("IF(A2:A" & LR & "=A1:A" & LR - 1 & ","""",A2:A" & LR & ")")
  With Range("A1:A" & LR).SpecialCells(xlBlanks)
    For Each Ar In .Areas
      Ar(1).Offset(-1, 2) = Join(Application.Transpose(Ar.Offset(-1, 2).Resize(Ar.Count + 1)), ", ")
    Next
    .EntireRow.Delete
  End With
End Sub[/td]
[/tr]
[/table]
 

MickG

MrExcel MVP
Joined
Jan 9, 2008
Messages
14,841

ADVERTISEMENT

Your quite right that should have been "Dn.offset(,2)"
It was just a typo Incurred when I was testing the code.
Well spotted
Regards Mick
 

Beth0331

New Member
Joined
Jun 13, 2018
Messages
7
Hi Rick, thank you for this. It seems like both yours & Mick's macro's are based off of the Name column and not the user ID. When i tried to amend the code to look at column B, and cell B2 It works only if the user IDs are in order but not if they are out of order. Can you help me fix that?


Sub DedupeAndConcatenate()
Dim LR As Long, Ar As Range
LR = Cells(Rows.Count, "B").End(xlUp).Row
Range("B2:B" & LR) = Evaluate("IF(B2:B" & LR & "=B1:B" & LR - 1 & ","""",B2:B" & LR & ")")
With Range("B1:B" & LR).SpecialCells(xlBlanks)
For Each Ar In .Areas
Ar(1).Offset(-1, 1) = Join(Application.Transpose(Ar.Offset(-1, 1).Resize(Ar.Count + 1)), ", ")
Next
.EntireRow.Delete
End With
End Sub
 

Peter_SSs

MrExcel MVP, Moderator
Joined
May 28, 2005
Messages
52,277
Office Version
  1. 365
Platform
  1. Windows
It works only if the user IDs are in order ..
That isn't too surprising since in post 1 you said "Currently it look like this:" and then gave sample data where the IDs were all grouped. ;)

Anyway, see if this does what you want. Test in a copy of your workbook.
Code:
Sub ConcatColors()
  Dim d As Object
  Dim a As Variant
  Dim i As Long
  
  Set d = CreateObject("Scripting.Dictionary")
  d.CompareMode = 1
  With Range("A2", Range("C" & Rows.Count).End(xlUp))
    a = .Value
    For i = 1 To UBound(a)
      d(a(i, 1) & "," & a(i, 2)) = d(a(i, 1) & "," & a(i, 2)) & ", " & a(i, 3)
    Next i
    .ClearContents
    With .Columns(1).Resize(d.Count)
      .Value = Application.Transpose(d.Keys)
      .TextToColumns DataType:=xlDelimited, Comma:=True, Space:=False, Other:=False
    End With
    With .Columns(3).Resize(d.Count)
      .Value = Application.Transpose(d.Items)
      .TextToColumns DataType:=xlFixedWidth, FieldInfo:=Array(Array(0, 9), Array(2, 1))
      .Columns.AutoFit
    End With
  End With
End Sub
 
Master Excel Bundle

Excel contains over 450 functions, with more added every year. That’s a huge number, so where should you start? Right here with this bundle.

Forum statistics

Threads
1,151,983
Messages
5,767,438
Members
425,414
Latest member
chwein

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