ActiveSheet.ListObjects("Table_tb").ListColumns(2).Range.Select 

Option Explicit

Sub Test()
  Dim n&, i&, j&, tmp As String, keys As String
   
  n = Cells(Rows.Count, 1).End(xlUp).Row
  
  Range("D2:E" & n).ClearContents
  Application.ScreenUpdating = False
  
  Range("XX2:XY" & 3 * n).ClearContents
  Range("XX1:XY" & n) = Range("A1:B" & n).Value
  ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Clear
  ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Range("XX2:XX" & n) _
      , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
  With ActiveWorkbook.Worksheets("Sheet1").Sort
    .SetRange Range("XX1:XY" & n)
    .Header = xlYes
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
  End With
  
  j = 1
  For i = 2 To n
    j = j + 1
    tmp = Cells(i, 648)
    keys = ""
    While tmp = Cells(i, 648)
      keys = keys & Cells(i, 649) & ", "
      i = i + 1
    Wend
    i = i - 1
    Cells(j, 4) = tmp
    Cells(j, 5) = Left(keys, Len(keys) - 2)
  Next i
  Range("XX1:XY" & n).ClearContents
  Cells(1, 4) = "Name"
  Cells(1, 5) = "Keys"
  Cells(2, 4).Select
  Application.ScreenUpdating = True
End Sub

=ТРАНСП(B1:D1)

{=TRANSPOSE(A1:A20)}

target = Application.Transpose(arr)