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

[Beth0331]

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:

Name	User ID	Colors
John Doe	jdoe3	blue
John Doe	jdoe3	yellow
John Doe	jdoe3	green
John Doe	jdoe3	orange
John Doe	jdoe3	red
John Doe	jdoe3	purple
Jane Smith	jsmith5	green
Jane Smith	jsmith5	orange
Jane Smith	jsmith5	red
George Phillips	gphillips	blue
George Phillips	gphillips	green

<tbody>
</tbody>

I would like it to look like this:

Name	User ID	Colors
John Doe	jdoe3	blue, yellow, green, orange, red, purple
Jane Smith	jsmith5	green, orange, red
George Phillips	gphillips	blue, green

<tbody>
</tbody>

I'm using excel 2016

Thank You!

 

[MickG]

Try this:-

[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]

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]

Here is another macro that you can consider...

[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]

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]

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]

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.

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