concatenate text from multiple cells based on different cell values

[glad_ir]

Hello,

I wonder if somebody could help with this one please.

I have a sheet with peoples names in column A and their assigned Team in column B (e.g. Team A, Team B). Is there a way to concatenate all the people assigned a common team in a single cell - e.g. the names of all the people assigned Team A in cell D1 separated by commas or every better on different "rows" within the cell (not sure rows is the correct term here).

Any help would be very much appreciated.

thank you,
Iain

 

[kvsrinivasamurthy]

Pl enclose screenshot or file.

 

[Peter_SSs]

You could try this macro with a copy of your workbook.

Sub ListTeamMembers()
  Dim d As Object
  Dim a As Variant
  Dim i As Long
  
  a = Range("A2", Range("B" & Rows.Count).End(xlUp)).Value
  Set d = CreateObject("Scripting.Dictionary")
  
  For i = 1 To UBound(a)
    If d.exists(a(i, 2)) Then
      d(a(i, 2)) = d(a(i, 2)) & vbLf & a(i, 1)
    Else
      d(a(i, 2)) = a(i, 1)
    End If
  Next i
  Range("D1").Resize(2, d.Count).Value = Application.Index(Array(d.keys, d.Items), 0, 0)
End Sub

My sample data is in columns A:B below and the other columns were produced by the above code.

glad_ir.xlsm
	A	B	C	D	E	F
1	Name	Team		Team A	Team B	Team C
2	Name 1	Team A		Name 1 Name 4	Name 2 Name 3 Name 6	Name 5
3	Name 2	Team B
4	Name 3	Team B
5	Name 4	Team A
6	Name 5	Team C
7	Name 6	Team B
8
Sheet1

 

[glad_ir]

Hi Peter,

Thank you for your reply. This is amazing and works a treat!

Can I make a further request please. Can the code be modified to concatenate the names of the members for Team A in cell D1 with "Team A" in cell E1, the names of the members of Team B in cell D2 with "Team B" in E2, members of Team C in cell D3 with "Team C" in cell E3 etc? I have tried to modify but don't know what I'm doing!

Thank you again for your help.
Iain

 

[Peter_SSs]

Can the code be modified to concatenate the names of the members for Team A in cell D1 with "Team A" in cell E1, the names of the members of Team B in cell D2 with "Team B" in E2, members of Team C in cell D3 with "Team C" in cell E3 etc?

Like this?

Sub ListTeamMembers_v2()
  Dim d As Object
  Dim a As Variant
  Dim i As Long
  
  a = Range("A2", Range("B" & Rows.Count).End(xlUp)).Value
  Set d = CreateObject("Scripting.Dictionary")
  
  For i = 1 To UBound(a)
    If d.exists(a(i, 2)) Then
      d(a(i, 2)) = d(a(i, 2)) & vbLf & a(i, 1)
    Else
      d(a(i, 2)) = a(i, 1)
    End If
  Next i
  Range("D1").Resize(d.Count, 2).Value = Application.Transpose(Array(d.Items, d.Keys))
End Sub

glad_ir.xlsm
	A	B	C	D	E
1	Name	Team		Name 1 Name 4	Team A
2	Name 1	Team A		Name 2 Name 3 Name 6	Team B
3	Name 2	Team B		Name 5	Team C
4	Name 3	Team B
5	Name 4	Team A
6	Name 5	Team C
7	Name 6	Team B
8
Sheet1

 

[glad_ir]

Like this?

Sub ListTeamMembers_v2()
  Dim d As Object
  Dim a As Variant
  Dim i As Long
 
  a = Range("A2", Range("B" & Rows.Count).End(xlUp)).Value
  Set d = CreateObject("Scripting.Dictionary")
 
  For i = 1 To UBound(a)
    If d.exists(a(i, 2)) Then
      d(a(i, 2)) = d(a(i, 2)) & vbLf & a(i, 1)
    Else
      d(a(i, 2)) = a(i, 1)
    End If
  Next i
  Range("D1").Resize(d.Count, 2).Value = Application.Transpose(Array(d.Items, d.Keys))
End Sub

glad_ir.xlsm
	A	B	C	D	E
1	Name	Team		Name 1 Name 4	Team A
2	Name 1	Team A		Name 2 Name 3 Name 6	Team B
3	Name 2	Team B		Name 5	Team C
4	Name 3	Team B
5	Name 4	Team A
6	Name 5	Team C
7	Name 6	Team B
8
Sheet1

Exactly like that! Thank you so much for your help. I am in awe of your coding skills.

thank you,
Iain

 

[glad_ir]

Like this?

Sub ListTeamMembers_v2()
  Dim d As Object
  Dim a As Variant
  Dim i As Long
 
  a = Range("A2", Range("B" & Rows.Count).End(xlUp)).Value
  Set d = CreateObject("Scripting.Dictionary")
 
  For i = 1 To UBound(a)
    If d.exists(a(i, 2)) Then
      d(a(i, 2)) = d(a(i, 2)) & vbLf & a(i, 1)
    Else
      d(a(i, 2)) = a(i, 1)
    End If
  Next i
  Range("D1").Resize(d.Count, 2).Value = Application.Transpose(Array(d.Items, d.Keys))
End Sub

glad_ir.xlsm
	A	B	C	D	E
1	Name	Team		Name 1 Name 4	Team A
2	Name 1	Team A		Name 2 Name 3 Name 6	Team B
3	Name 2	Team B		Name 5	Team C
4	Name 3	Team B
5	Name 4	Team A
6	Name 5	Team C
7	Name 6	Team B
8
Sheet1

Hi Peter,

Apologies - one last request. Is it possible to limit the macro to work within a specified number of rows - i.e. only concatenate names in rows A2 to A30 and ignore anything from A31 down?

Thank you,
Iain

 

[Peter_SSs]

Try

Sub ListTeamMembers_v3()
  Dim d As Object
  Dim a As Variant
  Dim i As Long
  
  a = Range("A2:B30").Value
  Set d = CreateObject("Scripting.Dictionary")
  
  For i = 1 To UBound(a)
    If Len(a(i, 1)) > 0 Then
      If d.exists(a(i, 2)) Then
        d(a(i, 2)) = d(a(i, 2)) & vbLf & a(i, 1)
      Else
        d(a(i, 2)) = a(i, 1)
      End If
    End If
  Next i
  Range("D1").Resize(d.Count, 2).Value = Application.Transpose(Array(d.Items, d.Keys))
End Sub

 

[glad_ir]

Try

Sub ListTeamMembers_v3()
  Dim d As Object
  Dim a As Variant
  Dim i As Long
 
  a = Range("A2:B30").Value
  Set d = CreateObject("Scripting.Dictionary")
 
  For i = 1 To UBound(a)
    If Len(a(i, 1)) > 0 Then
      If d.exists(a(i, 2)) Then
        d(a(i, 2)) = d(a(i, 2)) & vbLf & a(i, 1)
      Else
        d(a(i, 2)) = a(i, 1)
      End If
    End If
  Next i
  Range("D1").Resize(d.Count, 2).Value = Application.Transpose(Array(d.Items, d.Keys))
End Sub

This is perfect!

Thank you so much for your help.

Best regards,
Iain

 

[Peter_SSs]

You're welcome. Thanks for the follow-up.