Transposing Data - Multiple Entries horizontally for the same values from A column

[GoranH]

Good day people,

I have a list that looks like this

Name	Thing
Bob	apple
Ann	pear
Marie	dog
Bob	cat
Marie	white
Ann	red
George	black
Ann	purple

I need it to look like this

Bob	apple	cat
Ann	pear	red	purple
Marie	dog	white
George	black

Help would be very appreciated. About a year ago one of your members helped me with the same issue.

Help with Transposing

Here's an example: John apple John fridge John heart John pear John car Steven soap Steven display Steven pen Steven orange Steven bee I would like it to look like, John apple fridge heart pear Car Steven soap display pen orange bee My sheet is mostly...

www.mrexcel.com

However that solution doesn't work at all anymore.

If it helps, all my "Names" are in A column, and all the "things" are in the B column.

 

[Peter_SSs]

all my "Names" are in A column, and all the "things" are in the B column.

Assuming that and columns to the right are empty, try this with a copy of your data

Sub Rearrange()
  Dim a As Variant
  Dim d As Object
  Dim i As Long
  
  a = Range("A2", Range("B" & Rows.Count).End(xlUp)).Value
  Set d = CreateObject("Scripting.Dictionary")
  d.CompareMode = 1
  For i = 1 To UBound(a)
    d(a(i, 1)) = d(a(i, 1)) & ";" & a(i, 2)
  Next i
  With Range("D2:E2").Resize(d.Count)
    .Value = Application.Transpose(Array(d.Keys, d.Items))
    .Columns(2).TextToColumns DataType:=xlDelimited, Tab:=False, Semicolon:=True, Comma:=False, Space:=False, Other:=False, FieldInfo:=Array(1, 9)
    .Rows(0).Value = Array("Name", "Things")
  End With
End Sub

My data & results:

GoranH 1.xlsm
	A	B	C	D	E	F	G	H
1	Name	Thing		Name	Things
2	Bob	apple		Bob	apple	cat
3	Ann	pear		Ann	pear	red	purple
4	Marie	dog		Marie	dog	white
5	Bob	cat		George	black
6	Marie	white
7	Ann	red
8	George	black
9	Ann	purple
Sheet1

 

[Fluff]

How about

Sub GoranH()
   Dim Ary As Variant
   Dim i As Long
  
   Ary = Sheets("Sheet1").Range("A1").CurrentRegion.Value2
   With CreateObject("scripting.dictionary")
      For i = 2 To UBound(Ary)
         .Item(Ary(i, 1)) = .Item(Ary(i, 1)) & Ary(i, 2) & "|"
      Next i
      Sheets("Sheet2").Range("A2").Resize(.Count, 2).Value = Application.Transpose(Array(.keys, .items))
   End With
   With Sheets("Sheet2")
      .Range("B:B").TextToColumns .Range("B1"), xlDelimited, , , False, False, False, False, True, "|"
   End With
End Sub

Beaten 2it

 

[GoranH]

Thanks to both you, sincerely.

I've tried Peter's solution first and it worked, so I'll go with that.

Have a nice day guys, and thanks for the help!

 

[Fluff]

Glad we could help & thanks for the feedback.

 

[Peter_SSs]

Cheers. Glad it helped.