List Attributes in column M for every match found in Category Name (Column A)

[surkdidat]

Raw Data:-

COLUMN A	COLUMN M
ID Number	Attribute
11111	Horse
11111	Cat
11111	Dog
11112	Spiderpig
11112	Dog
11112	Horse
11113	Dog
11114	Cat
11114	Horse
11113	Horse
11113	Spiderpig
11113	Cat
11113	Penguin
11111	Penguin

Desired Outcome (New Sheet)

Column A	Column B	Column C	Column D	Column E	Column F	Column G	Column H
ID	Match 1	Match 2	Match 3	Match 4	Match 5	Match 6	Match 7
11111	Horse	Cat	Dog	Penguin
11112	Spiderpig	Dog	Horse
11113	Dog	Horse	Spiderpig	Cat	Penguin
11114	Cat	Horse

There are over 10,000 rows in the spreadsheet (with approx 200 Unique IDS).

In Column M there ar a potential of 800 matches, but believe there should be no more than 20 in each unique ID that needs to be captured.

Thanks!

 

[JEC]

This should work.
I don't know how your dataset looks like, so I took range("A1:M15) for example.

Sub jec()
 Dim ar As Variant, a As Variant, i As Long
 ReDim sp(1000) As Variant
 ar = Sheets(1).Range("A1:M15")
 
 With CreateObject("scripting.dictionary")
   For i = 2 To UBound(ar)
     a = .Item(ar(i, 1))
     If IsEmpty(a) Then a = sp
        a(0) = ar(i, 1)
        a(UBound(a)) = a(UBound(a)) + 1
        a(a(UBound(a))) = ar(i, 13)
       .Item(ar(i, 1)) = a
   Next
   Sheets(2).Cells(2, 1).Resize(.Count, UBound(a)) = Application.Index(.items, 0, 0)
 End With
     
End Sub

 

[JEC]

Could be done pretty easily with power query aswell

 

[surkdidat]

This should work.
I don't know how your dataset looks like, so I took range("A1:M15) for example.

Sub jec()
 Dim ar As Variant, a As Variant, i As Long
 ReDim sp(1000) As Variant
 ar = Sheets(1).Range("A1:M15")
 
 With CreateObject("scripting.dictionary")
   For i = 2 To UBound(ar)
     a = .Item(ar(i, 1))
     If IsEmpty(a) Then a = sp
        a(0) = ar(i, 1)
        a(UBound(a)) = a(UBound(a)) + 1
        a(a(UBound(a))) = ar(i, 13)
       .Item(ar(i, 1)) = a
   Next
   Sheets(2).Cells(2, 1).Resize(.Count, UBound(a)) = Application.Index(.items, 0, 0)
 End With
   
End Sub

thanks very much for your help ...... Just realised is it possible to also include Column I and have it return for "YES" only please?

 

[JEC]

Like this?

Sub jec()
 Dim ar As Variant, a As Variant, i As Long
 ReDim sp(1000) As Variant
 ar = Sheets("Blad1").Range("A1:M15")
 
 With CreateObject("scripting.dictionary")
   For i = 2 To UBound(ar)
     a = .Item(ar(i, 1))
     If IsEmpty(a) Then a = sp
        a(0) = ar(i, 1)
        If ar(i, 9) = "YES" Then
           a(UBound(a)) = a(UBound(a)) + 1
           a(a(UBound(a))) = ar(i, 13)
          .Item(ar(i, 1)) = a
        End If
   Next
   Sheets("Blad2").Cells(2, 1).Resize(.Count, UBound(a)) = Application.Index(.items, 0, 0)
 End With
     
End Sub